unit AppMain;

interface

Const

VertexCount = 21;

VertexNames: array[0..VertexCount-1] of String = ('Рязань','Егорьевск', 'Луховицы', 'Зарайск',

'Михайлов', 'Воскресенск', 'Коломна',

'Озеры', 'Кимовск', 'Кашира', 'Венев', 'Новомосковск',

'Донской', 'Болохово', 'Киреевск', 'Тула', 'Щекино',

'Серпухов', 'Балабаново', 'Калуга', 'Суворов');

type

TVertex = Shortint;

TEdge = record

v: array[0..1] of TVertex; {Индексы вершин}

d: Word; {Distance}

end;

TGraph = array of TEdge; {Массив ребер}

PGraph = ^TGraph;

TTrail = array of TVertex; {Массив вершин пути}

PTrail = ^TTrail;

{Graph}

procedure AddToGraph(Graph: PGraph; v1, v2: TVertex; d: Word);

{Trail}

function TrailToString(Trail: PTrail): String;

procedure AddToTrail(Trail: PTrail; Value: TVertex);

{Edge}

function FindEdge(Graph: PGraph; Vertex: TVertex; StartIndex: Integer = 0): Integer; overload;

function FindEdge(Graph: PGraph; v1, v2: TVertex; StartIndex: Integer = 0): Integer; overload;

{Vertex}

function FindVertex(Trail: PTrail; Vertex: TVertex; StartIndex: Integer = 0): Integer;

{Search}

function DepthSearch(Const Graph: PGraph; FromVertex, ToVertex: TVertex; Trail: PTrail): Boolean;

function BreadthSearch(Const Graph: PGraph; FromVertex, ToVertex: TVertex; Trail: PTrail): Boolean;

function MsaSearch(Const Graph: PGraph; FromVertex, ToVertex: TVertex; Trail: PTrail): Boolean;

implementation

{Утилиты}

{Добавление ребра в граф}

procedure AddToGraph(Graph: PGraph; v1, v2: TVertex; d: Word);

Begin

SetLength(Graph^, High(Graph^)+2);

Graph^[High(Graph^)].v[0]:= v1;

Graph^[High(Graph^)].v[1]:= v2;

Graph^[High(Graph^)].d:= d;

end;

{Конвертирует путь в строку}

function TrailToString(Trail: PTrail): String;

Var i: Integer;

Begin

Result:= '';

for i:= 0 to High(Trail^) do

Result:= Result + VertexNames[Trail^[i]] + #13#10;

if Length(Result) >= 2 then

Delete(Result, Length(Result)-1, 2);

end;

{Добавляет вершину в карту маршрута}

procedure AddToTrail(Trail: PTrail; Value: TVertex);

Begin

SetLength(Trail^, High(Trail^)+2);

Trail^[High(Trail^)]:= Value;

end;

{Поиск вершины в карте маршрута}

function FindVertex(Trail: PTrail; Vertex: TVertex; StartIndex: Integer = 0): Integer;

Var i: Integer;

Begin

for i:= StartIndex to High(Trail^) do

if Trail^[i] = Vertex then

Begin

Result:= i;

Exit;

end;

Result:= -1;

end;

{Поиск ребра, в котором используется искомая вершина}

function FindEdge(Graph: PGraph; Vertex: TVertex; StartIndex: Integer = 0): Integer; overload;

Var i: Integer;

Begin

for i:= StartIndex to High(Graph^) do

if (Graph^[i].v[0] = Vertex) or (Graph^[i].v[1] = Vertex) then

Begin

Result:= i;

Exit;

end;

Result:= -1;

end;

{Поиск ребр, в котором используются искомые вершины}

function FindEdge(Graph: PGraph; v1, v2: TVertex; StartIndex: Integer = 0): Integer; overload;

Var i: Integer;

Begin

for i:= StartIndex to High(Graph^) do

if ((Graph^[i].v[0] = v1) and (Graph^[i].v[1] = v2)) or

((Graph^[i].v[0] = v2) and (Graph^[i].v[1] = v1)) then

Begin

Result:= i;

Exit;

end;

Result:= -1;

end;

{Записывает в массив Vertexes все вершины, соединенные с Vertex}

procedure NearVertexes(Const Graph: PGraph; Vertex: TVertex; var Vertexes: TTrail);

Var tmp: Integer;

Begin

SetLength(Vertexes, 0);

tmp:= -1;

repeat

tmp:= FindEdge(Graph, Vertex, tmp+1);

if tmp <> -1 then

if Graph^[tmp].v[0] = Vertex then

AddToTrail(@Vertexes, Graph^[tmp].v[1]) else

AddToTrail(@Vertexes, Graph^[tmp].v[0]);

until (tmp = -1);

end;

{Агоритмы поисков}

{Поиск в глубину}

type THeuristicsFunc = procedure(Const Graph: PGraph; SrcVertex: TVertex; _DestNear: PTrail);

function CustomDepthSearch(Const Graph: PGraph; FromVertex, ToVertex: TVertex; Trail: PTrail; Hf: THeuristicsFunc): Boolean;

Var Was: array[0..VertexCount] of Boolean; {Массив посещенных вершин}

function _recursion(v: TVertex; depth: Integer): Boolean;

Var _Near: TTrail;

i: Integer;

Begin

Result:= true;

try

Was[v]:= true;

{Добавляем вершину в список пути}

if depth > High(Trail^) then

AddToTrail(Trail, v) else

Trail^[depth]:= v;

{Проверяем на целевую}

if v = ToVertex then

Begin

SetLength(Trail^, depth+1);

Exit;

end;

{Проходимся по соседним}

Hf(Graph, v, @_Near);

for i:= 0 to High(_Near) do

if (not Was[_Near[i]]) and _recursion(_Near[i], depth+1) then

Exit;

Result:= false;

finally

Was[v]:= false;

end;

end;

Begin

SetLength(Trail^, 0);

FillChar(Was[0], VertexCount, 0);

Result:= _recursion(FromVertex, 0);

end;

{Поиск в глубину, процедура __SimpleDepth - вызывается для определения порядка,

тут не используются сортировка, просто получение соседей}

procedure __SimpleDepth(Const Graph: PGraph; SrcVertex: TVertex; _DestNear: PTrail);

Begin

NearVertexes(Graph, SrcVertex, _DestNear^);

end;

function DepthSearch(Const Graph: PGraph; FromVertex, ToVertex: TVertex; Trail: PTrail): Boolean;

Begin

Result:= CustomDepthSearch(Graph, FromVertex, ToVertex, Trail, __SimpleDepth);

end;

{Поиск в ширину}

function BreadthSearch(Const Graph: PGraph; FromVertex, ToVertex: TVertex; Trail: PTrail): Boolean;

Var TempList, History, _Near: TTrail;

Was: array[0..VertexCount - 1] of Boolean; {Массив посещенных вершин}

Map: array[0..VertexCount - 1] of TVertex; {Массив вершин из которых пришли к определенной}

tmp, last: TVertex; {Текущий и предыдущий}

i: Integer;

function _removeFirst(ATrail: PTrail): TVertex; {Удаляет первый элемент из очереди}

Begin

Result:= ATrail^[0];

Move(ATrail^[1], ATrail^[0], High(ATrail^));

SetLength(ATrail^, High(ATrail^));

end;

Begin

{Инициализация}

SetLength(Trail^, 0);

SetLength(History, 0);

SetLength(TempList, 0);

FillChar(Was[0], VertexCount, 0);

FillChar(Map[0], VertexCount, 0);

{Добвляем первую вешину}

AddToTrail(@TempList, FromVertex);

AddToTrail(@History, FromVertex);

repeat

{Берем нулевой элемент}

tmp:= _removeFirst(@TempList);

last:= _removeFirst(@History);

if Was[tmp] then

Continue;

Map[tmp]:= last;

Was[tmp]:= true;

if tmp = ToVertex then

Begin

{Формируем путь с помощью истории переходов}

AddToTrail(Trail, tmp);

repeat

tmp:= Map[tmp];

AddToTrail(Trail, tmp);

until tmp = FromVertex;

{Выходим с true}

Result:= true;

Exit;

end;

{Добавляем соседей}

NearVertexes(Graph, tmp, _Near);

for i:= 0 to High(_Near) do

Begin

AddToTrail(@TempList, _Near[i]);

AddToTrail(@History, tmp);

end;

until (High(TempList) = -1);

Result:= false;

end;

{Поиск наискорейшим подъемом}

procedure __MsaHeuristics(Const Graph: PGraph; SrcVertex: TVertex; _DestNear: PTrail);

Var i: Integer;

tmp: TVertex;

swaped: Boolean;

Begin

NearVertexes(Graph, SrcVertex, _DestNear^);

{Сортируем по длинне по убыванию}

repeat

swaped:= false;

for i:= 0 to High(_DestNear^) - 1 do

if Graph^[FindEdge(Graph, SrcVertex, _DestNear^[i])].d <

Graph^[FindEdge(Graph, SrcVertex, _DestNear^[i+1])].d then

Begin

tmp:= _DestNear^[i];

_DestNear^[i]:= _DestNear^[i+1];

_DestNear^[i+1]:= tmp;

swaped:= true;

end;

until not swaped;

end;

function MsaSearch(Const Graph: PGraph; FromVertex, ToVertex: TVertex; Trail: PTrail): Boolean;

Begin

Result:= CustomDepthSearch(Graph, FromVertex, ToVertex, Trail, __MsaHeuristics);

end;

end.

Дата добавления: 2015-08-05