Методы решения транспортной задачи (метод потенциалов)

    procedure PageControl1Change(Sender: TObject);

    procedure Button1Click(Sender: TObject);

    procedure StringGrid1KeyPress(Sender: TObject; var Key: Char);

    procedure FormCreate(Sender: TObject);

    procedure Button2Click(Sender: TObject);

    procedure Button3Click(Sender: TObject);

    procedure Button6Click(Sender: TObject);

    procedure Button8Click(Sender: TObject);

    procedure PaintBox1MouseDown(Sender: TObject; Button: TMouseButton;

      Shift: TShiftState; X, Y: Integer);

    procedure PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X,

      Y: Integer);

    procedure PaintBox1MouseUp(Sender: TObject; Button: TMouseButton;

      Shift: TShiftState; X, Y: Integer);

    procedure PaintBox1Paint(Sender: TObject);

    procedure Button7Click(Sender: TObject);

  private

    { Private declarations }

  public

    fData: TData;

 

    fFigures: TList;

    fLines: TList;

 

    fMouseState : integer;

    fMouseInd: integer;

 

    { Public declarations }

 

    function Check( data: TData ): boolean;

 

    procedure CalcNorthWest( data: TData; var plan: TData );

    procedure CalcMinEl( data: TData; var plan: TData );

 

    procedure CalcPotential( data: TData; var plan, x: TData );

 

    procedure Dump( data: TData; fl: integer );

 

    function CalcSum( data, plan: TData ): integer;

 

    procedure ShiftPlan( var data, plan, potential: TData );

 

    // graphics

    procedure Redraw;

    function IsOver( x,y: integer ): integer;

    procedure AddRemoveLine( i1, i2: integer );

  end;

 

var

  Form1: TForm1;

 

implementation

 

{$R *.dfm}

uses size;

 

procedure TForm1.Button1Click(Sender: TObject);

var

  index, s: integer;

begin

  if Size_f1.ShowModal () <> mrOk then

    exit;

 

  s := StrToInt( Size_f1.Cols_e1.Text );

  StringGrid1.ColCount := s + 2;

  for index := 1 to s do

    StringGrid1.Cells[index+1,0] := IntToStr( index );

 

  s := StrToInt( Size_f1.Rows_e1.Text );

  StringGrid1.RowCount := s + 2;

  for index := 1 to s do

    StringGrid1.Cells[0, index+1] := IntToStr( index );

end;

 

procedure TForm1.StringGrid1KeyPress(Sender: TObject; var Key: Char);

begin

  if (StringGrid1.Col = 1) and (StringGrid1.Row = 1) then

    begin

      Key := #0;

      exit;

    end;

 

  if (Key < '0') or (Key > '9') then

    Key := #0;

end;

 

procedure TForm1.FormCreate(Sender: TObject);

begin

  StringGrid1.Cells[1,0] := 'Магазины';

  StringGrid1.Cells[0,1] := 'Склады';

  StringGrid1.Cells[1,1] := 'Наличие \ Потребность';

 

  FillChar( fData, sizeof(fData), 0 );

 

  fFigures := TList.Create;

  fLines := TList.Create;

  fMouseState := 0;

end;

 

procedure TForm1.Button2Click(Sender: TObject);

 

function GetInt( x, y: integer ): integer;

begin

  Result := StrToInt( StringGrid1.Cells[ x, y ] );

end;

 

var

  index, index2, s, old_s: integer;

  data, plan, potential: TData;

begin

  Memo1.Lines.Clear;

 

 

  data := TData.Create;

 

  data.Width := StringGrid1.ColCount-2;

  data.Height := StringGrid1.RowCount-2;

 

  for index := 0 to data.Height-1 do

    for index2 := 0 to data.Width-1 do

      data.Arr[index2,index] := GetInt( index2+2, index+2 );

 

  for index := 0 to data.Width-1 do

    data.Top[index] := GetInt( index+2, 1 );

 

  for index := 0 to data.Height-1 do

    data.Left[index] := GetInt( 1, index+2 );

 

  plan := TData.Create;

  potential := TData.Create;

 

  Memo1.Lines.Add( 'Data' );

  Dump( data, 7 );

 

  Memo1.Lines.Add( 'Plan:' );

 

  CalcNorthWest( data, plan );

  Dump( plan, 1 );

  Memo1.Lines.Add( 'Sum: ' + IntToStr( CalcSum(data, plan) ) );

 

  old_s := 0;

  while (true) do

    begin

      CalcPotential( data, plan, potential );

      Memo1.Lines.Add( 'Потенциал:' );

      Dump( potential, 1 ); {}

      if (potential.Min >= 0) then

        begin

          Memo1.Lines.Add( 'Программа завершена!' );

          break;

        end;

 

      ShiftPlan( data, plan, potential );

 

      s := CalcSum(data, plan);

      Memo1.Lines.Add( 'Результат:' );

      Dump( plan, 1 );

      Memo1.Lines.Add( 'Сумма: ' + IntToStr(s) ); {}

 

      if (old_s = s) then

        break

      else

        old_s := s;

    end;

end;

 

procedure TData.Assign(data: TData);

var

  index, index2: integer;

begin

  AssignLT( data );

 

  for index := 0 to Height-1 do

    for index2 := 0 to Width-1 do

      Arr[index2,index] := data.Arr[index2,index];

end;

 

procedure TData.AssignLT(data: TData);

var

  index: integer;

begin

  Reset;

 

  Width := data.Width;

  Height := data.Height;

 

  for index := 0 to Width-1 do

    Top[index] := data.Top[index];

 

  for index := 0 to Height-1 do

    Left[index] := data.Left[index];

end;

 

constructor TData.Create;

begin

  Reset;

end;

 

function TForm1.Check(data: TData): boolean;

var

  s, index: integer;

begin

  s := 0;

 

  for index := 0 to data.Width-1 do

    s := s + data.Top[index];

 

  for index := 0 to data.Height-1 do

    s := s - data.Left[index];

 

  Result := s = 0;

end;

 

procedure TForm1.CalcNorthWest( data: TData; var plan: TData);

var

  index, index2, t: integer;

begin

  index := 0;

  index2 := 0;

 

  plan.AssignLT( data );

 

  while (index < plan.Height) and (index2 < plan.Width) do

    begin

      t := min( plan.Left[index], plan.Top[index2] );

 

      plan.Arr[index2,index] := t;

 

      plan.Top[index2] := plan.Top[index2]-t;

      plan.Left[index] := plan.Left[index]-t;

 

      if (plan.Top[index2] = 0) then

        index2 := index2+1;

 

      if (plan.Left[index] = 0) then

        index := index+1;

    end;

end;

 

procedure TForm1.Dump(data: TData; fl: integer);

 

function i2s( i: integer ): string;

var

  r: string;

begin

  r := IntToStr( i );

  while( length(r) < 3 ) do

    r := ' ' + r;

  Result := r;

end;

 

var

  index, index2: integer;

  s: string;

begin

  if ((fl and 2) <> 0) then

    begin

      s := '   ';

      for index := 0 to data.Width-1 do

        s := s + i2s( data.Top[index] );

 

      Memo1.Lines.Add( s );

    end;

 

  if ((fl and 5) = 0) then

    exit;

 

  for index := 0 to data.Height-1 do

    begin

      if ((fl and 4) <> 0) then

        s := i2s( data.Left[index] )

      else

        s := '';

 

      if  ((fl and 1) <> 0) then

        for index2 := 0 to data.Width-1 do

          s := s + i2s( data.Arr[index2,index] );

 

      Memo1.Lines.Add( s );

    end;

end;

 

procedure TForm1.Button3Click(Sender: TObject);

 

procedure c( x, y: integer; s: string );

begin

  StringGrid1.Cells[ x, y ] := s;

end;

 

begin

  StringGrid1.ColCount := 6;

  StringGrid1.RowCount := 5;

 

 

  c( 2, 1, '5' );

  c( 3, 1, '9' );

  c( 4, 1, '9' );

  c( 5, 1, '7' );

 

 

  c( 1, 2, '11' );

  c( 1, 3, '11' );

  c( 1, 4, '8' );

 

 

  c( 2, 2, '7' );

  c( 3, 2, '8' );

  c( 4, 2, '5' );

  c( 5, 2, '3' );

 

  c( 2, 3, '2' );

  c( 3, 3, '4' );

  c( 4, 3, '5' );

  c( 5, 3, '9' );

 

  c( 2, 4, '6' );

  c( 3, 4, '3' );

  c( 4, 4, '1' );

  c( 5, 4, '2' );

end;

 

function TForm1.CalcSum(data, plan: TData): integer;

var

  index, index2, s: integer;

begin

  s := 0;

 

  for index := 0 to data.Height-1 do

    for index2 := 0 to data.Width-1 do

      s := s + data.Arr[index2,index] * plan.Arr[index2, index];

 

  Result := s;

end;

 

 

 

function TData.Min: integer;

var

  index, index2, m: integer;

begin

  m := MaxInt;

  for index := 0 to Height-1 do

    for index2 := 0 to Width-1 do

      if (m > Arr[index2,index]) then

        m := Arr[index2,index];

  Result := m;

end;

 

function TData.NoNulls: integer;

var

  index, index2, c: integer;

begin

  c := 0;

 

  for index := 0 to Height-1 do

    for index2:= 0 to Width-1 do

      if (Arr[index2,index] > 0) then

        inc(c);

 

  Result := c;

end;

 

procedure TForm1.CalcMinEl( data: TData; var plan: TData );

var

  index, index2, x_m, y_m, v_m, s, v: integer;

begin

  s := 0;

 

  plan.AssignLT( data );

 

  for index := 0 to plan.Width-1 do

    s := s + data.Top[index];

 

  while (s > 0) do

    begin

      v_m := MaxInt;

      x_m := -1;

      y_m := -1;

 

      for index := 0 to plan.Height-1 do

        for index2 := 0 to plan.Width-1 do

          if ((v_m > data.Arr[index2,index]) and

              (plan.Arr[index2,index] = 0) and

              (plan.Top[index2] > 0) and (plan.Left[index] > 0)) then

            begin

              v_m := data.Arr[index2,index];

 

              x_m := index2;

              y_m := index;

            end;

 

      if (v_m = MaxInt) then

        break;

 

      v := min( plan.Top[ x_m ], plan.Left[ y_m ] );

 

      plan.Top[ x_m ] := plan.Top[ x_m ] - v;

      plan.Left[ y_m ] := plan.Left[ y_m ] - v;

 

      plan.Arr[ x_m, y_m ] := v;

 

      s := s - v;

    end;

end;

 

procedure TData.Reset;

begin

  FillChar( Left, sizeof(Left), 0 );

  FillChar( Top, sizeof(Top), 0 );

  FillChar( Arr, sizeof(Arr), 0 );

end;

 

procedure TEqSolve.AddEq( p1,p2,s : integer );

begin

  Eq[ fEqCount ].p1 := p1;

  Eq[ fEqCount ].p2 := p2 + fH;

  Eq[ fEqCount ].sum := s;

  Eq[ fEqCount ].solved := false;

 

  Form1.Memo1.Lines.Add( 'u' + IntToStr(p1+1) + ' + v' + IntToStr(p2+1) +

    ' = ' + IntToStr( s ) ); {}

 

  inc( fEqCount );

end;

 

constructor TEqSolve.Create( h, v_c: integer );

begin

  FillChar( Eq, sizeof(Eq), 0 );

  FillChar( fV, sizeof(fV), 0 );

 

  fEqCount := 0;

  fVarCount := v_c;

  fH := h;

end;

 

function TEqSolve.GetU(index: integer): TVar;

begin

  Result := fV[index];

end;

 

function TEqSolve.GetV(index: integer): TVar;

begin

  Result := fV[index+fH];

end;

 

procedure TEqSolve.Solve;

var

  non_solved, index, c: integer;

  ceq: ^TEquation;

begin

  FillChar( fV, sizeof(fV), 0 );

  non_solved := fVarCount-1;

 

  fV[0].v := 0;

  fV[0].solved := true;

 

  while (non_solved > 0) do

    begin

      c := 0;

      for index := 0 to fEqCount-1 do

        begin

          ceq := @Eq[index];

          if (ceq.solved) then continue;

 

          if (fV[ ceq.p1 ].solved) then

            begin

              fV[ ceq.p2 ].v := ceq.sum - fV[ ceq.p1 ].v;

              fV[ ceq.p2 ].solved := true;

              inc(c);

              ceq.solved := true;

            end

          else if (fV[ ceq.p2 ].solved) then

            begin

              fV[ ceq.p1 ].v := ceq.sum - fV[ ceq.p2 ].v;

              fv[ ceq.p1 ].solved := true;

              inc(c);

              ceq.solved := true;

            end;

        end;

 

      if (c = 0) then

        exit;

    end;

end;

 

procedure TForm1.CalcPotential(data: TData; var plan, x: TData);

 

function to_sign( v: integer ): integer;

begin

  if (v = 0) then

    Result := 1

  else

    Result := -1;

end;

 

var

  index, index2, t: integer;

  solve: TEqSolve;

  s: string;

begin

  solve := TEqSolve.Create( plan.Height, plan.Height + plan.Width );

 

  for index := 0 to plan.Height-1 do

    for index2 := 0 to plan.Width-1 do

      if (plan.Arr[index2,index] > 0) then

        solve.AddEq( index, index2, data.Arr[index2,index] );

 

  index := 0;

  index2 := 0;

  while (solve.fEqCount < plan.Height + plan.Width-1) do

    begin

      inc(index2);

      if (index2 = plan.Width) then

        begin

          index2 := 0;

          inc( index );

 

          if (index = plan.Height) then

            break;

        end;

 

      if (plan.Arr[index2,index] = 0) then

        solve.AddEq( index, index2, data.Arr[index2,index] );

    end;

 

  solve.Solve;

 

 

  s := 'u: ';

  for index := 0 to plan.Height-1 do

    s := s + ' ' + IntToStr( solve.U[index].v );

  Form1.Memo1.Lines.Add( s );

 

  s := 'v: ';

  for index := 0 to plan.Width-1 do

    s := s + ' ' + IntToStr( solve.V[index].v );

  Form1.Memo1.Lines.Add( s );

 

  x.Reset;

  x.AssignLT( data );

 

  for index := 0 to plan.Height-1 do

    for index2 := 0 to plan.Width-1 do

      if (plan.Arr[index2,index] = 0) then

        begin

          t := (solve.V[index2].v + solve.U[index].v);

          x.Arr[index2,index] := data.Arr[index2,index] - t;

        end;

end;

 

procedure TForm1.ShiftPlan(var data, plan, potential: TData );

var

  x_m, y_m, v_m, f, f2: integer;

  a: TData;

  flag: boolean;

 

procedure Line( x, y, vert, val: integer );

begin

  if (vert = 1) then y := plan.Width-1

  else               x := 0;

 

  while (x < plan.Width) and (y >= 0)  and (not flag) do

    begin

      if (plan.Arr[x,y] <> 0) and (a.Arr[x,y] = 0) then

        begin

          a.Arr[x,y] := val;

          if (x = x_m) and (vert = 0) then

            flag := true;

        end;

 

      if (vert = 1) then  dec(y)

      else                inc(x);

    end;

end;

 

procedure Find( var x, y: integer; vert, val: integer );

begin

  if (vert = 1) then  y := 0

  else                x := 0;

 

  while (x < plan.Width) and (y < plan.Height) do

    begin

      if a.Arr[x,y] = val then

        break;

 

      if (vert = 1) then  inc(y)

      else                inc(x);

    end;

end;

 

var

  index, index2, x1, y1: integer;

  path: array [0..100] of TPoint;

begin

  FillChar( path, sizeof(path), 0 );

 

  x_m := -1;

  y_m := -1;

  v_m := MaxInt;

 

  for index := 0 to plan.Height-1 do

    for index2 := 0 to plan.Width-1 do

      if (potential.Arr[index2,index] < v_m) then

        begin

          x_m := index2;

          y_m := index;

          v_m := potential.Arr[index2,index];

        end;

 

  a := TData.Create;

  a.AssignLT( plan );

 

  a.Arr[x_m,y_m] := 1;

 

  flag := false;

  f := 1;

  while not flag do

    begin

      for index := 0 to plan.Height-1 do

        for index2 := 0 to plan.Width-1 do

          if (a.Arr[index2,index] = f) then

            begin

              Line( index2, index, (f+1) and 1, f+1 );

 

            end;

 

      inc( f );

    end;

 

  Memo1.Lines.Add( 'path: ');

  Dump( a, 1 );

 

 

  x1 := x_m;

  y1 := y_m;

  f2 := f;

 

  while (f >= 0) do

    begin

      path[f].x := x1;

      path[f].y := y1;

 

      Find( x1, y1, (f+1) and 1, f );

 

      dec(f);

    end;

 

  v_m := MaxInt;

  x_m := -1;

  index := 1;

  while (index < f2) do

    begin

      f := plan.Arr[ path[index].x, path[index].y ];

      if (f < v_m) then

        begin

          v_m := f;

          x_m := index;

        end;

 

      inc(index,2);

    end;

 

 

  for index := 0 to f2-1 do

    begin

      f := plan.Arr[ path[index].x, path[index].y ];

 

      if ( (index and 1) = 0 ) then   f := f + v_m

      else                            f := f - v_m;

 

      plan.Arr[ path[index].x, path[index].y ] := f;

    end;

end;

 

 

 

procedure TForm1.Button6Click(Sender: TObject);

var

  fig: TFigure;

  s: string;

begin

  fig := TFigure.Create;

 

  fig.x := PaintBox1.Width div 2;

  fig.y := PaintBox1.Height div 2;

 

  if (MessageBox( 0, 'Это поставщик?', 'Вопрос', MB_YESNO ) = ID_YES) then

    fig.flag := 0

  else

    fig.flag := 1;

 

  s := InputBox( 'Введите количество товара', '', '1' );

  fig.val := StrToInt( s );

 

  fFigures.Add( fig );

 

  Redraw;

end;

 

procedure TForm1.Redraw;

var

  index: integer;

  canv: TCanvas;

  fig, fig2: TFigure;

  l: TLine;

begin

  canv := PaintBox1.Canvas;

 

  canv.Brush.Color := clWhite;

  canv.FillRect( Rect(0,0, PaintBox1.Width, PaintBox1.Height) );

 

  canv.Font.Color := clBlack;

 

  for index := 0 to fLines.Count-1 do

    begin

      l := fLines.Items[index];

 

      fig := fFigures.Items[ l.i1 ];

      canv.MoveTo( fig.x, fig.y );

 

      fig2 := fFigures.Items[ l.i2 ];

      canv.LineTo( fig2.x, fig2.y );

 

      canv.TextOut( (fig.x + fig2.x) div 2 - 10, (fig.y + fig2.y) div 2 - 10,

        ' ' + IntToStr( l.val ) + ' ' );

    end;

 

  canv.Font.Color := clYellow;

 

  for index := 0 to fFigures.Count-1 do

    begin

      fig := fFigures.Items[index];

 

      if (fig.flag = 0) then

        canv.Brush.Color := clBlue

      else

        canv.Brush.Color := clRed;

 

      canv.Rectangle( fig.x-fFigSize, fig.y-fFigSize,

        fig.x+fFigSize, fig.y+fFigSize );

 

      canv.TextOut( fig.x - 10, fig.y - 10,

        ' ' + IntToStr( fig.val ) + ' ' );

    end;

end;

 

function TForm1.IsOver(x, y: integer): integer;

var

  index: integer;

  fig: TFigure;

begin

  for index := 0 to fFigures.Count-1 do

    begin

      fig := fFigures.Items[index];

 

      if (  (abs( fig.x - x ) <= fFigSize) and

            (abs( fig.y - y ) <= fFigSize) ) then

        begin

          Result := index;

          exit;

        end;

    end;

 

  Result := -1;

end;

 

procedure TForm1.AddRemoveLine(i1, i2: integer);

var

  index, f: integer;

  l: TLine;

  s: string;

begin

  if ((i1 < 0) or (i2 < 0) or (i1 = i2)) then

    exit;

 

  f := 0;

  for index := 0 to fLines.Count-1 do

    begin

      l := fLines.Items[index];

 

      if (((l.i1 = i1) and (l.i2 = i2)) or

          ((l.i2 = i1) and (l.i1 = i2)) ) then

        begin

          f := 1;

          break;

        end

    end;

 

  if (f = 1) then

    begin

      fLines.Delete( index );

      l.Destroy;

    end

  else

    begin

      l := TLine.Create;