5.2.Метод гілок та меж

{********************* Метод гілок та меж*************************}

function Vetvi_I_Granicy(var Matr: Matrix; N, Ver: Byte;

var Ans: ShortPath): Boolean;

{Matr - матрица весов в орграфе на N вершинах (0-нет ребра).

Исходная вершина имеет номер Ver

Ans - оптимальный путь в графе

Функция возвращает True, если задача решена и False,

если в графе вообще нет гамильтоновых циклов }

const

ZERO = 1.E-15; {Машинный ноль}

INFINITY = 1.E+30; {Машинная бесконечность}

type

{Описатель границы - вершины строящегося дерева}

PBound = ^TBound;

TBound = record

M: Matrix; {Матрица границы}

Fi: Double; {Значение оценочной функции на данной границе}

RibCol: Byte; {Количество отобранных ребер обхода на данной границе}

Ribs: array [1..NVer, 1..2] of Byte; {Отобранные ребра: Ribs[i,1],

Ribs[i,2] начальная и конечная вершины ребра i}

Pred: PBound {Указатель на неразработ. границу предыдущего уровня}

end;

function BegVerInRibs(Ver: Byte; Bound: PBound): Boolean;

{Возвращает True, если вершина Ver является начальной

вершиной какого-либо ребра Bound^.Ribs и False в

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

var

i: Byte;

begin

BegVerInRibs := False;

for i:=1 to Bound^.RibCol do

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

begin

BegVerInRibs := True;

Break

end

end; {BegVerInRibs}

function EndVerInRibs(Ver: Byte; Bound: PBound): Boolean;

{Возвращает True, если вершина Ver является конечной

вершиной какого-либо ребра Bound^.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) then

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) then

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);

New(Left);

Left^ := Bound^;

with Left^ do

begin

RibCol := RibCol+1;

Ribs[RibCol,1]:=Row;

Ribs[RibCol,2]:=Col;

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); {Приводим матрицу}

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: Matrix; 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: Matrix; {Весовая матрица, где "нули" заменены на "бесконечность"}

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;

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, если найденный путь бесконечной длины)}

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

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

Dispose(Rec)

end;