Поиск гамильтонова цикла в ориентированном графе

(*
 
http://rain.ifmo.ru/cat/view.php/theory/graph-circuits-cuts/hamiltonian-2005
Алгоритм нахождения гамильтонова цикла
 
Рассмотрим рекурсивную функцию searchHamiltonianCycle, которая возвращает true, если граф является гамильтоновым, и false в противном случае.
 
 
  searchHamiltonianCycle(0, 0, numberOfVertices);
  bool searchHamiltonianCycle(int v, int w, int d) {
1*  if (d == 1 && w прринадлежит Adj[v]) return true;
2   visited[v] = true;
3   for (для) всех вершин t принадлежит Adj[v]
4     if (!visited[t])
5       if (searchHamiltonianCycle(t, w, d-1))
6         return true;
7*  visited[v] = false;
8   return false;
  }
 
    numberOfVertices — число вершин в графе
    v — последняя найденная вершина
    w — начальная вершина (с нее начинается поиск)
    d — оставшаяся длина гамильтонова цикла
 
Данный алгоритм напоминает алгоритм поиска в глубину (DFS). Основные отличия отмечены красным цветом (символом '*'):
1. функция принимает начальную вершину w и длину гамильтонова цикла в качестве второго и третьего параметров соответственно;
2. в строке 1, функция проверяет, все ли вершины были посещены (d == 1), и если это так, то существует ли ребро, соединяющее
    начальную вершину с конечной. Если оба условия выполнены, то гамильтонов цикл найден;
3. в строке 7, функция переустанавливает значение маркера visited, прежде чем возвратит значение, означающие неуспех.
*)
 
program HamiltonCycle;
 
type
  TMatrixAdjacent = array of array of integer;
  TArray = array of integer;
 
  function ReadMatrixAdjacentFromFile(s: string; var M: TMatrixAdjacent;
  var NVertex: integer): boolean;
  var
    f: Text;
    i, j: integer;
  begin
    Assign(f, s);
    reset(f);
    readln(f, NVertex);
    SetLength(M, NVertex, NVertex);
    for i := 0 to NVertex - 1 do
    begin
      for j := 0 to NVertex - 1 do
        Read(f, M[i, j]);
      readln(f);
    end;
    Close(f);
    ReadMatrixAdjacentFromFile := True;
  end;
 
  procedure ShowMatrix(const M: TMatrixAdjacent; n: integer);
  var
    i, j: integer;
  begin
    for i := 0 to n - 1 do
    begin
      for j := 0 to n - 1 do
        Write(M[i, j]: 2);
      writeln;
    end;
  end;
 
  {функция определяет - орграф или не орграф по симметричности матрицы смежности}
  function IsDigraph(const M: TMatrixAdjacent; NVertex: integer): boolean;
  var
    i, j: integer;
    Res:  boolean;
  begin
    Res := True;
    for i := 0 to NVertex - 1 do
      for j := 0 to NVertex - 1 do
        Res := Res and (M[i, j] = M[j, i]);
    IsDigraph := Res;
  end;
 
{
Степень вершины (англ. degree, также валентность, англ. valency)
в теории графов — количество рёбер графа G, инцидентных вершине x.
При подсчёте степени ребро-петля учитывается дважды.
}
  {для неориентированного графа}
  function deg(v: integer; const M: TMatrixAdjacent; NVertex: integer): integer;
  var
    j: integer;
  begin
    deg := 0;
    for j := 0 to NVertex - 1 do
      if M[v, j] <> 0 then
        Inc(deg);
    if M[v, v] <> 0 then
      Inc(deg);
  end;
 
  {
  полустепень. количество входящих рёбер орграфа.
  }
  function indegree(v: integer; const M: TMatrixAdjacent; NVertex: integer): integer;
  var
    j: integer;
  begin
    indegree := 0;
    for j := 0 to NVertex - 1 do
      if M[v, j] <> 0 then
        Inc(indegree);
  end;
 
  {
  полустепень. количество исходящих рёбер орграфа.
  }
  function outdegree(v: integer; const M: TMatrixAdjacent; NVertex: integer): integer;
  var
    i: integer;
  begin
    outdegree := 0;
    for i := 0 to NVertex - 1 do
      if M[v, i] <> 0 then
        Inc(outdegree);
  end;
 
  {
   Необходимое условие существования гамильтонова пути в неориентированном графе:
   если неориентированный граф G содержит гамильтонов цикл, тогда в нём не существует
   ни одной вершины x(i) с локальной степенью p(x(i)) < 2.
  }
  function HamiltonianProperty(const M: TMatrixAdjacent; NVertex: integer): boolean;
  var
    x, y: integer;
    Res:  boolean;
  begin
    Res := (NVertex >= 3);
    if Res then
    begin
      for x := 0 to NVertex - 1 do
        Res := Res and (deg(x, M, NVertex) >= 2);
    end;
    HamiltonianProperty := Res;
  end;
 
  {
  условие Дирака существования гамильтонова пути:
  пусть p — число вершин в данном графе и p>=3;
  если степень каждой вершины не меньше, чем p/2, то данный граф — гамильтонов.
  Это достаточное условие не является необходимым.
 
  Условие - для простого графа (Простой граф — граф, в котором нет кратных рёбер и петель.)
  }
  function Dirac(const M: TMatrixAdjacent; NVertex: integer): boolean;
  var
    Res: boolean;
    v: integer;
  begin
    Res := (NVertex >= 3);
    if Res then
    begin
      for v := 0 to NVertex - 1 do
        Res := Res and (deg(v, M, NVertex) >= (NVertex div 2));
    end;
    Dirac := Res;
  end;
 
  {
  Условие Оре:
   пусть p — количество вершин в данном графе и p>2.
   Если для любой пары несмежных вершин (x, y) выполнено неравенство
   deg(x) + deg(y) >= p, то данный граф — гамильтонов (другими словами:
   сумма степеней любых двух несмежных вершин не меньше общего числа вершин в графе).
  }
  function Ore(const M: TMatrixAdjacent; NVertex: integer): boolean;
  var
    x, y: integer;
    Res:  boolean;
  begin
    Res := (NVertex >= 3);
    if Res then
    begin
      for x := 0 to NVertex - 1 do
        for y := 0 to NVertex - 1 do
          if (M[x, y] = 0) and (M[y, x] = 0) then
            Res := Res and (deg(x, M, NVertex) + deg(y, M, NVertex) >= NVertex);
    end;
    Ore := Res;
  end;
 
  function FindHamiltonianCycle(M: TMatrixAdjacent; NVertex: integer): boolean;
  var
    Visited: array of boolean;
    Path: TArray;
 
    function searchHamiltonianCycle(v, w, d: integer): boolean;
    var
      t: integer;
    begin
      if (d = 1) and (M[v, w] = 1) then
      begin
        Path[NVertex - d] := v;
        searchHamiltonianCycle := True;
        exit;
      end;
      Visited[v] := True;
      for t := 0 to NVertex - 1 do
      begin
        if M[v, t] = 0 then
          continue;
        if not Visited[t] then
          if searchHamiltonianCycle(t, w, d - 1) then
          begin
            Path[NVertex - d] := v;
            searchHamiltonianCycle := True;
            exit;
          end;
      end;
      Visited[v] := False;
      searchHamiltonianCycle := False;
    end;
 
  var
    i: integer;
  begin
    SetLength(Path, NVertex);
    SetLength(Visited, NVertex);
    for i := 0 to NVertex - 1 do
      Visited[i] := False;
    FindHamiltonianCycle := searchHamiltonianCycle(0, 0, NVertex);
    if FindHamiltonianCycle then
      for i := 0 to NVertex - 1 do
        Write(Path[i]: 3);
    writeln;
  end;
 
var
  MA: TMatrixAdjacent;
  NVertex: integer;
begin
  ReadMatrixAdjacentFromFile('MatrixAdjacent.txt', MA, NVertex);
  ShowMatrix(MA, NVertex);
  Write('The Hamiltonian graph property gives ');
  if HamiltonianProperty(MA, NVertex) then
    writeln('positive result.')
  else
    writeln('negative result.');
  Write('The Dirac condition of Hamiltonian graph gives ');
  if Dirac(MA, NVertex) then
    writeln('positive result.')
  else
    writeln('negative result.');
  Write('The Ore condition of Hamiltonian graph gives ');
  if Ore(MA, NVertex) then
    writeln('positive result.')
  else
    writeln('negative result.');
  writeln('Hamiltonian:');
  if FindHamiltonianCycle(MA, NVertex) then
    writeln('Exist')
  else
    writeln('No exist');
end.

procedure gamilton(var a,b,x:matr; n:integer);
var i,j,k,z:integer;
begin
for i:=1 to n do
 for j:=1 to n do
 b[i,j]:=a[i,j];
 for z:=1 to n-1 do begin
for i:=1 to n do
 for j:=1 to n do
 begin
  x[i,j]:=0;
  for k:=1 to n do
  x[i,j]:=x[i,j]+a[i,k]*b[k,j];
 end;
   for i:=1 to n do
 for j:=1 to n do  a[i,j]:=x[i,j];
 writeln;
 for i:=1 to n do begin
 for j:=1 to n do
 write(x[i,j]);
 writeln; end;
 end;
end;