Кратчайший путь из города в город

Ribs и False в

противном случае}

var

i: Byte;

begin

EndVerInRibs := False;

for i:=1 to Bound^.RibCol do

if Bound^.Ribs[i, 2] = Ver then

begin

EndVerInRibs := True;

Break

end

end; {EndVerInRibs}

procedure ReductMatr (Bound: PBound; N: Byte);

{Осуществляет приведение матрицы Bound^.M размером NxN

Увеличивает Bound^.Fi на сумму констант приведения}

var

i, j: Byte;

Min: Double; {Миним. элемент в строке или столбце}

begin

{Приведение по строкам}

for i:=1 to N do

if not BegVerInRibs (i, Bound) then

begin

Min := 2*INFINITY;

{Ищем минимальный элемент}

for j:=1 to N do

if (EndVerInRibs (j, Bound)=False)and (Bound^.M[i, j]

Min := Bound^.M[i, j];

{Производим приведение}

Bound^.Fi := Bound^.Fi+Min;

for j:=1 to N do

if not EndVerInRibs (j, Bound) then

Bound^.M[i, j] := Bound^.M[i, j]-Min

end;

{Приведение по столбцам}

for j:=1 to N do

if not EndVerInRibs (j, Bound) then

begin

Min := 2*INFINITY;

{Ищем минимальный элемент}

for i:=1 to N do

if (BegVerInRibs (i, Bound)=False)and (Bound^.M[i, j]

Min := Bound^.M[i, j];

{Производим приведение}

Bound^.Fi := Bound^.Fi+Min;

for i:=1 to N do

if not BegVerInRibs (i, Bound) then

Bound^.M[i, j] := Bound^.M[i, j]-Min

end

end; {ReductMatr}

procedure FindHeavyZero (Bound: PBound; N: Byte; var Row: Byte; var Col: Byte);

{Находит «самый тяжелый ноль» матрицы Bound^.M размером NxN и возвращает строку Row и столбец Col в котором этот ноль был найден}

var

TmpBound: TBound; {Вспомогательная переменная для приведения матриц}

MaxW: Double; {Вес «самого тяжелого нуля» }

i, j: Byte;

begin

Row := 0; {Еще ничего}

Col := 0; {не найдено}

MaxW := -1.0;

for i:=1 to N do

if not BegVerInRibs (i, Bound) then

for j:=1 to N do

if not EndVerInRibs (j, Bound) then

if Bound^.M[i, j] < ZERO then

begin {Нашли очередной ноль — подсчитать его вес}

TmpBound := Bound^;

TmpBound.M[i, j] := 2*INFINITY;

TmpBound.Fi := 0.0;

ReductMatr (@TmpBound, N);

if TmpBound. Fi > MaxW then

begin

Row := i;

Col := j;

MaxW := TmpBound. Fi

end

end

end; {FindHeavyZero}

function IsCycle (Bound: PBound; V1, V2: Byte): Boolean;

{Проверяет, образует ли ребро (V1,V2) замкнутый контур с ребрами из

Bound^.Ribs}

var

i: Byte;

V: Byte; {Конечная вершина текущего построения}

CycLen: Byte; {Количество ребер в текущем построении}

label

loop;

begin

IsCycle := False;

V := V2; {Начинаем строить цикл от ребра (V1,V2)}

CycLen := 1;

with Bound^ do

while CycLen < RibCol+1 do

begin

for i:=1 to RibCol do

if Ribs[i, 1] = V then

begin {Нашли очередное ребро}

V := Ribs[i, 2];

CycLen := CycLen + 1;

if V = V1 then

IsCycle:=True {Контур замкнулся полностью}

else

goto loop {Продолжим искать ребра}

end;

Break; {Не находим продолжения обхода — выход}

loop:

end

end; {IsCycle}

procedure NewLevel (Bound: PBound; var Left: PBound; var Right: PBound);

{Разбивает границу Bound на левую и правую часть (Left и Right).

— в левой части остаются все циклы, в которые входит ребро,

соответствующее клетке с наиболее «тяжелым нулем» (список отобранных

ребер пополняется данным ребром).

— в правой части остаются все циклы в которые не входит ребро, отобранное

для левой части

Затем матрицы приводятся

}

var

i, j, k: Byte;

Row, Col: Byte; {координаты «самого тяжелого нуля» }

begin

{Находим «самый тяжелый ноль» }

FindHeavyZero (Bound, N, Row, Col);

{Создаем элемент Left}

New (Left);

Left^ := Bound^; {Копируем структуру полностью}

with Left^ do

begin

{Добавить ребро (Row, Col)}

RibCol := RibCol+1;

Ribs[RibCol, 1]: =Row;

Ribs[RibCol, 2]: =Col;

{Заменить на бесконечность клетки ребер,

позволяющие замкнуть ребра из Ribs в цикл без обхода всех вершин}

if RibCol < N-1 then

{Нужно добавить в цикл более одного ребра — нельзя допускать,

чтобы одно ребро завершило цикл}

for i:=1 to N do

if not BegVerInRibs (i, Left) then {Строка не вычеркнута}

for j:=1 to N do

if not EndVerInRibs (j, Left) then {Столбец не вычеркнут}

if M[i, j] < INFINITY then {Ребро (i, j) существует}

if IsCycle (Left, i, j) then {Оно может завершить цикл}

M[i, j] := 2*INFINITY {Удаляем это ребро}

end;

ReductMatr (Left, N); {Приводим матрицу}

{Создаем элемент Right}

New (Right);

Right^ := Bound^; {Копируем структуру полностью}

Right^.M[Row, Col] := 2*INFINITY; {Убрать циклы, в которые входит (Row, Col)}

ReductMatr (Right, N) {Приводим матрицу}

end; {NewLevel}

procedure BuildRecord (Bound: PBound; N: Byte);

{Превращение в рекорд границы Bound с матрицей NxN и одним невычеркнутым ребром добавлением этого невычеркнутого ребра в список ребер Ribs}

var

i, j: Byte;

begin

with Bound^ do

for i:=1 to N do

{Ищем невычеркнутую строку}

if not BegVerInRibs (i, Bound) then

for j:=1 to N do

{Ищем невычеркнутый столбец}

if not EndVerInRibs (j, Bound) then

begin {Добавляем ребро (i, j) в множество Ribs}

RibCol := RibCol + 1;

Ribs[RibCol, 1] := i;

Ribs[RibCol, 2] := j;

Fi := Fi + M[i, j];

Exit

end

end; {BuildRecord}

function BuildPath (Bound: PBound; var Matr: MatrType; N, BegVer: Byte;

var Path: ShortPath): Boolean;

{По лучшему рекорду Bound строит последовательный путь обхода Path, начиная

с вершины BegVer. С помощью исходной весовой матрицы Matr размером NxN,

подсчитывается длина пути. Если длина пути >= бесконечности, возвращается

False — пути нет, иначе возвращается True}

var

i, j: Byte;

PathLen: Double; {Длина пути}

begin

PathLen := 0.0;

Path[1] := BegVer;

with Bound^ do

begin

for i:=2 to N do

for j:=1 to RibCol do

if Ribs[j, 1] = Path[i-1] then

begin

Path[i] := Ribs[j, 2];

PathLen := PathLen + Matr[Path[i-1], Path[i]];

Break

end;

Path[RibCol+1] := BegVer;

PathLen := PathLen + Matr[Path[RibCol], Path[RibCol+1]]

end;

BuildPath := PathLen < INFINITY

end; {BuildPath}

{BranchAndBound}

var

i, j: Byte;

WMatr: MatrType; {Весовая матрица, где «нули» заменены на «бесконечность» }

CurBound: PBound; {Граница, разрабатываемая на текущем шаге}

Left, Right: PBound;{Результаты разбиения границы на две дочерних}

Rec: PBound; {Текущий рекорд}

TmpBound: PBound; {Вспомогательная переменная для обхода списка}

label

loop;

begin

{По исходной матрице инициализируем рабочую}

for i:=1 to N do

for j:=1 to N do

if Abs (Matr[i, j]) < ZERO then

WMatr[i, j] := 2*INFINITY

else

WMatr[i, j] := Matr[i, j];

{Инициализируем начальную границу рабочей матрицей}

New (CurBound);

with CurBound^ do

begin

M := WMatr;

Fi := 0.0;

RibCol := 0;

Pred := NIL

end;

ReductMatr (CurBound, N); {Привести матрицу}

{Основной цикл алгоритма — нахождение оптимального обхода коммивояжера}

loop:

{Прямой ход алгоритма — разработка границ до получения рекорда}

while CurBound^.RibCol < N-1 do

begin

{Разбиваем границу CurBound на две дочерних: Left и Right}

NewLevel (CurBound, Left, Right);

{Выбираем: какую из границ разрабатывать дальше}

if Left^.Fi <= Right^.Fi then

begin {Идем налево}

Right^.Pred := CurBound^.Pred;

Left^.Pred := Right;

Dispose (CurBound);

CurBound := Left;

end

else

begin {Идем направо}

Left^.Pred := CurBound^.Pred;

Right^.Pred := Left;

Dispose (CurBound);

CurBound := Right;

end

end;

{Имеем матрицу из 1-й клетки — превращаем ее в рекорд}

BuildRecord (CurBound, N);

Rec := CurBound; {Зафиксировать ссылку на рекорд}

CurBound := CurBound^.Pred; {Перейти на ближайшую неразработанную границу}

{Обратный ход алгоритма — улучшение рекорда}

while CurBound<>NIL do

begin

if CurBound^.Fi < Rec^.Fi then

begin {Начать разработку новой границы}

Dispose (Rec); {Освободить память, занятую рекордом}

goto loop;

end;

TmpBound := CurBound; {Подняться на уровень выше}

CurBound := CurBound^.Pred; {и удалить}

Dispose (TmpBound) {отсекаемую границу}

end;

{Преобразовать набор ребер в рекорде в последовательный путь Ans}

{(возвращается False, если найденный путь бесконечной длины)}

BranchAndBound := BuildPath (Rec, WMatr, N, Ver, Ans);

{Удалить рекорд}

Dispose (Rec)

end; {BranchAndBound}

{Главная программа}

var

i: Byte; {Индекс массива}

S: String; {Для формирования ответа}

Res: Boolean; {Результат выполнения метода решения}

Ans: ShortPath; {Ответ на задачу}

PathLong: Double;{Длина выбранного пути}

begin

{Договариваемся, что если в клетке Matr стоит 0,

то этого ребра не существует}

{Стираем предыдущий ответ}

AnswerEdit.Text:='';

LongEdit.Text:='';

{Выбираем метод решения}

case MetodRadioGroup. ItemIndex of

0: Res:=Exhaustive (Matr, N, StartSpinEdit. Value, Ans);

1: Res:=BranchAndBound (Matr, N, StartSpinEdit. Value, Ans)

end;

{Распечатываем результаты}

if Res then

begin

{Выводим маршрут}

S:='';

for i:=1 to N+1 do

begin

if i>1 then S:=S+' -> ';

S:=S+IntToStr (Ans[i])

end;

AnswerEdit.Text:=S;

{Выводим длину пути}

PathLong:=0.0;

for i:=1 to N do

PathLong:=PathLong+Matr[Ans[i], Ans[i+1]];

LongEdit.Text:=FloatToStrF (PathLong, ffFixed, 10,6)

end

else

ShowMessage ('Не найдено ни одного пути!')

end; {TMainForm.CountBtnClick}

procedure TMainForm. LoadBtnClick (Sender: TObject);

{С помощью диалога устанавливает размеры матрицы

весов, либо загружает ёё из файла}

{Читает файл для курсового проекта}

var

name: string; {Имя файла}

f: file of char; {Файл данных}

c: char; {Переменная для чтения данных}

i, j: byte; {Индексы}

S: ShortString; {Вспомогательная строка преобр.}

Code: Integer; {Контроль преобр.}

label

loop, loop1;

begin

{Вызываем диалог ввода параметров}

loop:

if ParamDlg. ShowModal=mrCancel then Exit; {Отказ от ввода}

if ParamDlg. RadioGroup1.ItemIndex=0 then

begin {Просто изменяем размеры}

N := StrToInt (ParamDlg.SizeEdit.Text);

ChangeTable;

Exit

end

else

begin {Читаем таблицу из файла}

if not FileExists (ParamDlg.FileEdit.Text)then

begin

ShowMessage ('Неверное имя файла!');

goto loop

end

else

name:=ParamDlg.FileEdit.Text

end;

{Устанавливаем переключатель на метод «ветвей и границ» .}

MetodRadioGroup.ItemIndex:=1;

{Открываем файл}

AssignFile (f, name);

reset (f);

{Пропускаем заголовок}

C:=' ';

While C<>':' do Read (f, C);

i:=0; {Номер текущей строки}

while true do

begin

C:=' ';

while (C<>':') do Read (f, C);{До очередн. строки}

Inc (i);

j:=0; {Номер текущего столбца}

while (C<>'L') do

begin {Читаем текущую строку}

if Eof (f) then goto loop1;

Read (f, C);

if C in ['0'.'9','.'] then

begin

S:='';

while C in ['0'.'9','.'] do

begin

S:=S+C;

Read (f, C);

end;

Inc (j);

Val (S, Matr[i, j], Code)

end

end

end;

loop1:

CloseFile (f);

N:=j;

ChangeTable

end; {TMainForm.LoadBtnClick}

procedure TMainForm. FormCreate (Sender: TObject);

{Начальная инициализация условия}

begin

N:=4;

ChangeTable

end; procedure TMainForm. lbTownsClick (Sender: TObject);

begin

end;

{TMainForm.FormCreate}

procedure TMainForm. SpeedButton1Click (Sender: TObject);

begin

MainForm.BtnGenerateClick (sender);

end;

procedure TMainForm. SpeedButton2Click (Sender: TObject);

begin

MainForm.btnDeleteTownClick (Sender);

end;

procedure TMainForm. SpeedButton3Click (Sender: TObject);

begin

MainForm.btnClearClick (Sender);

end;

procedure TMainForm. SpeedButton4Click (Sender: TObject);

begin

MainForm.BtnSetTownsClick (Sender);

end;

procedure TMainForm. SpeedButton5Click (Sender: TObject);

begin

form1.show;

end;

end.