Алгоритм Форда-Фалкерсона (Delphi -> PascalABC)

unit Unit1;
 
interface
 
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, Grids;
 
type
  TForm1 = class(TForm)
    Label1: TLabel;
    Label2: TLabel;
    Edit1: TEdit;
    Edit2: TEdit;
    Button1: TButton;
    StringGrid1: TStringGrid;
    Label3: TLabel;
    Edit3: TEdit;
    Label4: TLabel;
    Edit4: TEdit;
    Label5: TLabel;
    Button2: TButton;
    Memo1: TMemo;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Edit2Exit(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;
 
  const
  MaxV=1000;
  MaxE=30000;
 
  free_ = 0;
  bisy_ = 1;
  Great=MaxLongint;
 
  var
  Form1: TForm1;
 
implementation
 
{$R *.dfm}
 
procedure TForm1.FormCreate(Sender: TObject);
 var i: integer;
begin
  //Заполнить названия колонок в таблице
  StringGrid1.Cells[0, 0] := 'Ребро';
  StringGrid1.Cells[1, 0] := 'x';
  StringGrid1.Cells[2, 0] := 'y';
  StringGrid1.Cells[3, 0] := 'z';
  for I := 1 to Pred(StringGrid1.RowCount) do
    StringGrid1.Cells[0, i] := IntToStr(i);
  //Для примера заполнить таблицу
  StringGrid1.Cells[1, 1] := '1';
  StringGrid1.Cells[1, 2] := '1';
  StringGrid1.Cells[1, 3] := '2';
  StringGrid1.Cells[1, 4] := '2';
  StringGrid1.Cells[1, 5] := '3';
  StringGrid1.Cells[1, 6] := '4';
  StringGrid1.Cells[1, 7] := '5';
  StringGrid1.Cells[2, 1] := '2';
  StringGrid1.Cells[2, 2] := '3';
  StringGrid1.Cells[2, 3] := '4';
  StringGrid1.Cells[2, 4] := '5';
  StringGrid1.Cells[2, 5] := '4';
  StringGrid1.Cells[2, 6] := '6';
  StringGrid1.Cells[2, 7] := '6';
  StringGrid1.Cells[3, 1] := '1';
  StringGrid1.Cells[3, 2] := '1';
  StringGrid1.Cells[3, 3] := '1';
  StringGrid1.Cells[3, 4] := '1';
  StringGrid1.Cells[3, 5] := '1';
  StringGrid1.Cells[3, 6] := '1';
  StringGrid1.Cells[3, 7] := '1';
end;
 
procedure TForm1.Button1Click(Sender: TObject);
 var
  i: integer;
  n, m, last, s, t, x, y, z: longint;
  v,l: array[1..MaxV] of longint;
  adj, next, c, f: array[1..MaxE] of longint;
  found: boolean;
  MaxPOTOK: longint;
  prev: array [1..MaxV] of longint;
  Marked: array [1..MaxV] of byte;
  que,poz: array [1..MaxE] of longint;
  qb,qe: longint;
 
  procedure Init(n,m: longint);
  var
    i: longint;
  begin
    for i:=1 to n do
    begin
      v[i] := free_;
      l[i] := free_;
    end;
    for i:=1 to 2*m do
    begin
      adj[i] := free_;
      c[i] := free_;
      next[i] := free_;
      f[i] := free_;
    end;
    last := 0;
  end;
 
  procedure AddEdge(x,y,z: longint);
  begin
    inc(last);
    adj[last] := y;
    c[last] := z;
    if v[x] = free_ then
    begin
      v[x] := last;
    end else
      begin
        next[l[x]] := last;
      end;
    l[x] := last;
  end;
 
  procedure ErrorMes;
  begin
    ShowMessage('Неверно введены входные данные!');
    exit
  end;
 
  procedure Put(x: longint);
  begin
    inc(qe);
    que[qe]:=x;
    Marked[x]:=bisy_;
    prev[x]:=que[qb];
  end;
 
  procedure InitQue(x: longint);
  var
    i: longint;
  begin
    for i:=1 to 2*m do
    begin
      Marked[i]:=free_;
      poz[i]:=0;
    end;
    qb:=1;
    qe:=1;
    que[qe] := x;
    Marked[x] := bisy_;
  end;
 
  procedure FindWay;
  var
    x,Min,cf: longint;
  begin
    InitQue(s);
    while (qb<=qe)and(Marked[t]<>bisy_) do
    begin
      x:=v[que[qb]];
      while adj[x]<>free_ do
      begin
        if (Marked[adj[x]]<>bisy_)and(c[x]-f[x]>0) then
        begin
          Put(adj[x]);
          poz[adj[x]]:=x;
        end;
        x:=next[x];
      end;
      inc(qb);
    end;
    if Marked[t]=free_ Then
    begin
      Found:=False;
      Exit;
    end;
    Min:=Great;
    x:=t;
    while prev[x]<>free_ do
    begin
      cf:=c[poz[x]]-f[poz[x]]{!};
      if cf<Min Then Min:=cf;
      x:=prev[x];
    end;
    x:=t;
    while prev[x]<>free_ do
    begin
      f[poz[x]]:=f[poz[x]]+Min;
      if c[poz[x]]<>free_ then
         f[poz[x]+1]:=-f[poz[x]]
           else f[poz[x]-1]:=-f[poz[x]];
      x:=prev[x];
    end;
  end;
 
begin
 
  //Ввод данных
 
  //Количество вершин
  n := StrToIntDef(Edit1.Text, 0);
  m := StrToIntDef(Edit2.Text, 0);
  if (n = 0) or (m = 0) then ErrorMes;
  Init(n,m);
 
  //Матрица смежности
  for i := 1 to m do
  begin
    x := StrToIntDef(StringGrid1.Cells[1, i], 0);
    y := StrToIntDef(StringGrid1.Cells[2, i], 0);
    z := StrToIntDef(StringGrid1.Cells[3, i], 0);
    if (x <= 0) or (y <= 0) or (z <= 0) then ErrorMes;
    AddEdge(x,y,z);
    AddEdge(y,x,0);
  end;
 
  //Сток и исток (начальная и конечная вершины)
  s := StrToIntDef(Edit3.Text, 0);
  t := StrToIntDef(Edit4.Text, 0);
  if (s > n) or (s <= 0) or (t > n) or (t <= 0) then ErrorMes;
 
  //Вычисление по алгоритму Форда-Фалкерсона
  found:=true;
  while found do FindWay;
  MaxPOTOK := 0;
  x := v[s];
  while x <> free_ do
  begin
    if f[x] > 0 then
      MaxPOTOK := MaxPotok + f[x];
    x:=next[x];
  end;
  Memo1.Lines.Clear;
  Memo1.Lines.Add('Максимальный поток в заданном графе равен: '+ IntToStr(MaxPotok))
end;
 
 
procedure TForm1.Button2Click(Sender: TObject);
begin
Close
end;
 
procedure TForm1.Edit2Exit(Sender: TObject);
  var i: integer;
  m: longint;
begin
  m := StrToIntDef(Edit2.Text, 0);
  if m = 0 then
  begin
    ShowMessage('Неверно введены входные данные!');
    exit
  end;
  StringGrid1.RowCount := m + 1;
  for I := 1 to Pred(StringGrid1.RowCount) do
    StringGrid1.Cells[0, i] := IntToStr(i);
end;
 
end.