Транспортная задача: сравнение методов нахождения первоначального распределения

              Result[Length(Result) - 1].X:= k;

              Result[Length(Result) - 1].Y:= Result[Length(Result) - 2].Y;

              Break;

            end;

          end;

        end;

      until (Result[Length(Result) - 1].X = AI);

    end;

 

  const

    MAX = High(Integer);

  var

    RowPot, ColPot: TArray;

    NewMatr: TMatr;

    MinI, MinJ: Integer;

    Cicl: TPoints;

    Min: Integer;

 

    function AllFull: Boolean;

    var

      i: Integer;

    begin

      for i:= 0 to Length(APlan) - 1 do begin

        Result:= RowPot[i] <> MAX;

        if not Result then begin

         Exit;

        end;

      end;

      for i:= 0 to Length(APlan[0]) - 1 do begin

        Result:= ColPot[i] <> MAX;

        if not Result then begin

          Exit;

        end;

      end;

      Result:= True;

    end;

 

  var

    i, j, c: Integer;

 

  begin

    c:=0;

    SetLength(RowPot, Length(APlan));

    SetLength(ColPot, Length(APlan[0]));

    for i:= 0 to Length(APlan) - 1 do

      RowPot[i]:= MAX;

    ColPot[0]:= 0;

    for i:= 1 to Length(APlan[0]) - 1 do

      ColPot[i]:= MAX;

    repeat

      for i:= 0 to Length(APlan) - 1 do begin

        for j:= 0 to Length(APlan[0]) - 1 do begin

          if APlan[i, j] <> -1 then begin

            if (RowPot[i] = MAX) and (ColPot[j] = MAX) then

              Continue;

            if RowPot[i] = Max then

              RowPot[i]:= -(Matr[i, j] + ColPot[j])

            else

              ColPot[j]:= -(Matr[i, j] + RowPot[i]);

          end;

        end;

      end;

    until AllFull;

    MinI:= 0;

    MinJ:= 0;

    SetLength(NewMatr, Length(Matr), Length(Matr[0]));

    for i:= 0 to Length(AMatr) - 1 do begin

      for j:= 0 to Length(AMatr[0]) - 1 do begin

        NewMatr[i, j]:= Matr[i, j] + RowPot[i] + ColPot[j];

        if NewMatr[i, j] < NewMatr[MinI, MinJ] then begin

          MinI:= i;

          MinJ:= j;

       end;

      end;

    end;

    Form2.AddSheet1('Итерация' + IntToStr(c) , NewMatr);

    if NewMatr[MinI, MinJ] >= 0 then begin

      OptPlan:= True;

      Exit;

    end

    else

      OptPlan:= False;

    Cicl:= FindCicl(APlan, MinI, MinJ);

    i:= 3;

    MinI:= Cicl[1].X;

    MinJ:= Cicl[1].Y;

    Min:= APlan[MinI, MinJ];

    while i < Length(Cicl) do begin

      if Min > APlan[Cicl[i].X, Cicl[i].Y] then begin

        MinI:= Cicl[i].X;

        MinJ:= Cicl[i].Y;

        Min:= APlan[MinI, MinJ];

      end;

      inc(i, 2);

    end;

    for i:= 0 to Length(Cicl) - 1 do begin

      if i mod 2 = 0 then

        if APlan[Cicl[i].X, Cicl[i].Y] = -1 then

          inc(APlan[Cicl[i].X, Cicl[i].Y], Min + 1)

        else

          inc(APlan[Cicl[i].X, Cicl[i].Y], Min)

      else begin

        dec(APlan[Cicl[i].X, Cicl[i].Y], Min);

      end;

    end;

    APlan[MinI, MinJ]:= -1;

  end;

 

var

  OptPlan: Boolean;

  c,F: Integer;

begin

  c:= 0;

  repeat

    inc(c);

    NewPlan(AMatr, APlan, OptPlan);

    F:=Fun(AMatr, APlan);

    Form2.AddSheet('Итерация' + IntToStr(c)+ ' F = '+ IntToStr(F), APlan);

  until (OptPlan);

  Result:= APlan;

end;

 

procedure Solve(NorthWestCorner: TMatr);

var

  i, j, F: Integer;

  //TempC, TempP: TArray;

begin

  Plan:= NorthWestCorner;

  if not RightPlan(Plan) then begin

  MessageDlg ('План не удовлетворяет условию пост + потр – 1. Решаем задачу другим методом ', mtError, [mbOk], 0);

    for i:= 0 to Length(TempC) do

      Customers[i]:= TempC[i];

    for i:= 0 to Length(TempP) do

      Postavshiki[i]:= TempP[i];

    Plan:= NorthWestCorner;

  end;

  if not RightPlan(Plan) then begin

  MessageDlg ('План не удовлетворяет условию пост + потр – 1. Решаем задачу другим методом '', mtError, [mbOk], 0);

    for i:= 0 to Length(TempC) do

      Customers[i]:= TempC[i];

    for i:= 0 to Length(TempP) do

      Postavshiki[i]:= TempP[i];

    Plan:= MinCost;

  end;

  if not RightPlan(Plan) then begin

  MessageDlg('План не удовлетворяет условию пост + потр – 1. Решаем задачу другим методом ', mtError, [mbOk], 0);

    for i:= 0 to Length(TempC) do

      Customers[i]:= TempC[i];

    for i:= 0 to Length(TempP) do

      Postavshiki[i]:= TempP[i];

    Plan:= Fogel;

  end;

  F:=Fun(Matr, Plan);

  Form2.AddSheet('Опорный план F = '+ IntTostr(F), Plan);

  Plan:= PotencialMethod(Matr, Plan);

  F:=Fun(Matr, Plan);

  Form2.PageControl1.Pages[Form2.PageControl1.PageCount - 1].Caption:= 'Решение F = '+IntToStr(F);

  for i:= 0 to Form2.PageControl2.PageCount - 1 do begin

    Form2.PageControl2.Pages[i].Caption:= 'Итерация ' + IntToStr(i);

  end;

  Form1.Enabled:= True;

  Form2.StringGrid1.RowCount:= Form1.StringGrid1.RowCount+1;

  Form2.StringGrid1.ColCount:= Form1.StringGrid1.ColCount+1;

  for i:= 0 to Form1.StringGrid1.RowCount  do begin

    for j:= 0 to Form1.StringGrid1.ColCount do begin

      Form2.StringGrid1.Cells[i, j]:= Form1.StringGrid1.Cells[i, j];

    end;

  end;

  Form2.Show;

end;

 

end.

 
 
 

unit Unit2;

 

interface

 

uses

  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

  Dialogs, ComCtrls, Grids, TransportProblem, Unit1, StdCtrls, ShellAPI;

 

type

  TForm2 = class(TForm)

    PageControl1: TPageControl;

    PageControl2: TPageControl;

    Button1: TButton;

    Label1: TLabel;

    Label2: TLabel;

    StringGrid1: TStringGrid;

    Label3: TLabel;

    procedure Button1Click(Sender: TObject);

    procedure FormClose(Sender: TObject; var Action: TCloseAction);

  private

    { Private declarations }

  public

    { Public declarations }

    procedure AddSheet(Name: String; Plan: TMatr);

    procedure AddSheet1(Name: String; Matr: TMatr);

  end;

 

var

  Form2: TForm2;

 

implementation

 

{$R *.dfm}

 

procedure TForm2.AddSheet(Name: String; Plan: TMatr);

var

  Page1: TTabSheet;

  i, j: Integer;

begin

  Page1:= TTabSheet.Create(PageControl1);

  Page1.Caption:= Name;

  Page1.PageControl:= PageControl1;

  with TStringGrid.Create(Page1) do begin

    Align:= alClient;

    Parent:= Page1;

    FixedCols:= 0;

    FixedRows:= 0;

    RowCount:= Length(Plan);

    ColCount:= Length(Plan[0]);

    DefaultColWidth:= 32;

    DefaultRowHeight:= 23;

    for i:= 0 to RowCount - 1 do

      for j:= 0 to ColCount - 1 do

        if Plan[i, j] = -1 then

          Cells[j, i]:= '0'

        else

          Cells[j, i]:= IntToStr(Plan[i, j]);

  end;

end;

 

procedure TForm2.AddSheet1(Name: String; Matr: TMatr);

var

  Page1: TTabSheet;

  i, j: Integer;

begin

  Page1:= TTabSheet.Create(PageControl2);

  Page1.Caption:= Name;

  Page1.PageControl:= PageControl2;

  with TStringGrid.Create(Page1) do begin

    Align:= alClient;

    Parent:= Page1;

    FixedCols:= 0;

    FixedRows:= 0;

    RowCount:= Length(Matr);

    ColCount:= Length(Matr[0]);

    DefaultColWidth:= 32;

    DefaultRowHeight:= 23;

    for i:= 0 to RowCount - 1 do

      for j:= 0 to ColCount - 1 do

        Cells[j, i]:= IntToStr(Matr[i, j]);

  end;

end;

 

procedure TForm2.Button1Click(Sender: TObject);

begin

   Form2.Close;

end;

 

procedure TForm2.FormClose(Sender: TObject; var Action: TCloseAction);

begin

  ShellExecute(0, 'open', PChar(Application.ExeName), nil,

               nil,

               SW_SHOWNOACTIVATE);

  Halt;

end;

 

end.

 
 

program Project1;

 

uses

  Forms,

  Unit1 in 'Unit1.pas' {Form1},

  TransportProblem in 'TransportProblem.pas',

  Unit2 in 'Unit2.pas' {Form2};

 

{$R *.res}

 

begin

  Application.Initialize;

  Application.CreateForm(TForm1, Form1);

  Application.CreateForm(TForm2, Form2);

 

  if ParamCount > 0 then begin

    Form1.OpenDialog1.FileName:= ParamStr(1);

    Form1.Load;