unit main;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls, Grids;

const
MAXPATH = 1000; // максимальная длина пути м/д двумя вершинами
MAXTOWNCOUNT = 100; // максимальное количество вершин
type
TForm1 = class(TForm)
memRes: TMemo;
sgWeights: TStringGrid;
lbTowns: TListBox;
editTownName: TEdit;
btnAddTown: TButton;
btnDeleteTown: TButton;
Label1: TLabel;
btnGo: TButton;
Label2: TLabel;
Label3: TLabel;
btnClear: TButton;
btnGenerate: TButton;
btnSetTowns: TButton;
lblFirstTown: TLabel;
Label4: TLabel;
lblMAXPATH: TLabel;
procedure btnAddTownClick(Sender: TObject);
procedure btnSetTownsClick(Sender: TObject);
procedure sgWeightsSetEditText(Sender: TObject; ACol, ARow: Integer;
const Value: String);
procedure btnGenerateClick(Sender: TObject);
procedure btnClearClick(Sender: TObject);
procedure btnDeleteTownClick(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure btnGoClick(Sender: TObject);
private
// матрица весов (расстояний между городами)
Weights: array [0..MAXTOWNCOUNT-1, 0..MAXTOWNCOUNT-1] of integer;
// количество городов
towncount: integer;
// массивы для расчета
// город (вершина графа) уже обсчитан
Ready: array [0..MAXTOWNCOUNT-1] of boolean;
// текущий кратчайший пусть до этого города из первого
Paths: array [0..MAXTOWNCOUNT-1] of word;
// предпоследний узел пути из первого города до этого
Nodes: array [0..MAXTOWNCOUNT-1] of byte;
// индекс первого города
first: integer;
// очистка интерфейсной таблицы весов
procedure ClearGrid;
// перенести данные из TStringGrid в матрицу весов
procedure GetWeightsMatrix;
// инициализируем расчет
procedure FirstCountStep;
// запускаем расчет
procedure GoCount;
// результаты - в мемо
procedure ShowResults;
// все ли вершины обсчитаны?
function AllAreReady: boolean;
// получить необсчитанную вершину с наименьшим путем
function GetMinPath: word;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

(*------------------------------------
Добавить город в список
------------------------------------*)
procedure TForm1.btnAddTownClick(Sender: TObject);
begin
if editTownName.Text='' then
MessageDlg('Ошибка: Вы не ввели название города!', mtError, [mbOK], 0)
else begin
lbTowns.Items.Add(editTownName.Text);
editTownName.Text := '';
end;
end;


(*------------------------------------
Заполнить шапку таблицы названиями
городов из списка
------------------------------------*)
procedure TForm1.btnSetTownsClick(Sender: TObject);
var
i: integer;
begin
sgWeights.ColCount := lbTowns.Items.Count+1;
sgWeights.RowCount := lbTowns.Items.Count+1;
for i:=0 to lbTowns.Items.Count-1 do begin
sgWeights.Cells[i+1,0] := lbTowns.Items[i];
sgWeights.Cells[0,i+1] := lbTowns.Items[i];
end;
end;


(*------------------------------------
При изменении ячейки таблицы, вставляем
то же значение в симметричную ячейку
------------------------------------*)
procedure TForm1.sgWeightsSetEditText(Sender: TObject; ACol, ARow: Integer;
const Value: String);
begin
// делаем матрицу симметричной принудительно
sgWeights.Cells[ARow,ACol] := Value;
end;


(*------------------------------------
Сгенерировать расстояния между городами
случайным образом
------------------------------------*)
procedure TForm1.btnGenerateClick(Sender: TObject);
var
i, j: integer;
flag: real; // существует ли путь
begin
ClearGrid;
for i:=1 to sgWeights.ColCount-1 do begin
sgWeights.Cells[i,i] := '0';
for j:=i+1 to sgWeights.RowCount-1 do begin
flag := random;
if (flag>0.5) then begin
sgWeights.Cells[i,j] := IntToStr(random(MAXPATH));
sgWeights.Cells[j,i] := sgWeights.Cells[i,j];
end;
end;
end;
end;


(*------------------------------------
Очистить интерфейсную таблицу расстояний
между городами
------------------------------------*)
procedure TForm1.ClearGrid;
var
i, j: integer;
begin
for i:=1 to sgWeights.RowCount-1 do
for j:=1 to sgWeights.ColCount-1 do
sgWeights.Cells[i,j] := '';
end;


(*------------------------------------
Очистить список городов
------------------------------------*)
procedure TForm1.btnClearClick(Sender: TObject);
begin
lbTowns.Items.Clear;
end;


(*------------------------------------
Удалить выбранный город из списка
------------------------------------*)
procedure TForm1.btnDeleteTownClick(Sender: TObject);
var
i: integer;
begin
i:=0;
// не for, т.к. после удаления длина списка изменяется
while i<lbTowns.Items.Count do begin
if (lbTowns.Selected[i]) then
lbTowns.Items.Delete(i);
i := i+1;
end;
end;


(*------------------------------------
Заполняем матрицу весов из интерфейсной
таблицы
------------------------------------*)
procedure TForm1.GetWeightsMatrix;
var
i, j: integer;
begin
for i:=0 to towncount-1 do
Weights[i,i] := 0; // из города в сам себя
for i:=0 to towncount-1 do
for j:=i+1 to towncount-1 do
if sgWeights.Cells[i+1,j+1]='' then begin
Weights[i,j]:=MAXPATH+1; // считаем, что это бесконечность
Weights[j,i]:=MAXPATH+1; // симметрия
end
else begin
try // получаем значение
Weights[i,j]:=StrToInt(sgWeights.Cells[i+1,j+1]);
except
MessageDlg('Ошибка: значение в таблице не является целым числои!',
mtError, [mbOK], 0);
exit;
end;
// неотрицательное?
if Weights[i,j]<0 then begin
MessageDlg('Ошибка: значение в таблице не является неотрицательным!',
mtError, [mbOK], 0);
exit;
end;
// симметричная матрица
Weights[j,i] := Weights[i,j];
end; // else
end;


(*------------------------------------
При выводе формы
------------------------------------*)
procedure TForm1.FormShow(Sender: TObject);
begin
lblMAXPATH.Caption := IntToStr(MAXPATH);
end;


(*------------------------------------
Запуск расчета и вывод результатов -
сборка
------------------------------------*)
procedure TForm1.btnGoClick(Sender: TObject);
begin
towncount := lbTowns.Items.Count;
GetWeightsMatrix; // перебрасываем пути в матрицу
FirstCountStep; // инициализируем расчет
GoCount; // запускаем расчет
ShowResults; // результаты - в мемо
end;


(*------------------------------------
Инициализация расчета
------------------------------------*)
procedure TForm1.FirstCountStep;
var
i: integer;
begin
first := -1;
for i:=0 to towncount-1 do
if lbTowns.Selected[i] then
first := i;
if (first=-1) then begin
MessageDlg('Ошибка: вы не выбрали начальный город в списке!',
mtError, [mbOK], 0);
exit;
end;
lblFirstTown.Caption := lbTowns.Items[first];
for i:=0 to towncount-1 do begin
Ready[i] := false; // еще ничего не посчитано
Nodes[i] := first; // все как будто напрямую
Paths[i] := Weights[first,i]; // прямые пути
end;
end;


(*------------------------------------
Итерационная часть расчета
(собственно, сам алгоритм)
------------------------------------*)
procedure TForm1.GoCount;
var
k, cur: integer;
begin
while not AllAreReady() do begin
cur := GetMinPath;
Ready[cur] := true;
for k:=0 to towncount-1 do
if ((Ready[k]=false)and(Paths[k]>(Paths[cur]+Weights[cur,k]))) then begin
Paths[k] := Paths[cur]+Weights[cur,k];
Nodes[k] := cur;
end;
end;
end;


(*------------------------------------
Показать результаты: последовательности
перемещения и величины кратчайших путей
------------------------------------*)
procedure TForm1.ShowResults;
var
k, last: integer;
str: string;
i, j: integer;
begin
memRes.Lines.Clear;
for k:=0 to towncount-1 do begin
str := lbTowns.Items[k]+' ('+IntToStr(Paths[k])+')';
last := Nodes[k];
while last<>first do begin
str := lbTowns.Items[last]+' => '+str;
last := Nodes[last];
end;
str := lbTowns.Items[first]+' => '+str;
memRes.Lines.Add(str);
end;
end;


(*------------------------------------
Проверка: все ли вершины графа
обсчитаны
------------------------------------*)
function TForm1.AllAreReady: boolean;
var
i: integer;
begin
Result := true;
for i:=0 to towncount-1 do
if Ready[i]=false then
Result := false;
end;


(*------------------------------------
Получить необсчитанную вершину с
наименьшим текущим путем
------------------------------------*)
function TForm1.GetMinPath: word;
var
i, min, imin: integer;
begin
min := MAXPATH+1;
imin := 0;
for i:=0 to towncount-1 do
if ((Ready[i]=false)and(Paths[i]<min)) then begin
min := Paths[i];
imin := i;
end;
Result := imin;
end;

end.

---