Исходники.Ру - Программирование
Исходники
Статьи
Книги и учебники
Скрипты
Новости RSS
Магазин программиста

Главная » Статьи по программированию » Delphi - Алгоритмы и математика »

Обсудить на форуме Обсудить на форуме

Нахождение кратчайшего пути в ненаправленном графе

Наталья Массальская

Задача. Реализовать алгоритм поиска кратчайшего пути в ненаправленном графе расстояний между городами. Граф задается матрицей целочисленных весов. Считается, что все названия городов в списке - различны. Начальный город задает пользователь.

Вид основного окна программы

Код модуля main.pas

 
(******************************************
Реализовать алгоритм поиска кратчайшего пути в
ненаправленном графе расстояний между городами.
Граф задается матрицей целочисленных весов. Считается, что
все названия городов в списке - различны. Начальный город
задает пользователь.
-------------------------------------------
Delphi (Object Pascal)
-------------------------------------------
(c) 2006
Наталья Массальская
Проект "Аудитория"
www.lectureroom.net
******************************************)

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.

Программа тестировалась в среде Borland Delphi 7.0

Другие материалы автора Вы можете прочитать на сайте "Аудитория Натальи Массальской"


Может пригодится:


Автор: Наталья Массальская
Прочитано: 7078
Рейтинг:
Оценить: 1 2 3 4 5

Комментарии: (2)

Прислал: User
А как скачать прогу?

Прислал: Павел
афафаф

Добавить комментарий
Ваше имя*:
Ваш email:
URL Вашего сайта:
Ваш комментарий*:
Код безопастности*:

Рассылка новостей
Рейтинги
© 2007, Программирование Исходники.Ру