Нахождение эйлеровых циклов
Пусть дан орграф G с N вершинами. Эйлеровым циклом в нем называется цикл, в котором каждое ребро графа встречается ровно 1 раз. Можно доказать, что в графе существует эйлеров цикл (граф является эйлеровым) тогда и только тогда, когда граф, во-первых, является связным (не считая изолированных вершин), и, во-вторых, у каждой его вершины входящая степень равна исходящей.

Описанный алгоритм построения эйлеровых циклов уже предполагает, что граф эйлеров. Мы пойдем из любой неизолированной вершины (пусть это вершина 1), и будем идти, добавляя вершины в стек и удаляя ребра, по которым мы проходим, пока мы не сможем пойти из очередной вершины; тогда будем удалять вершины из стека в порядок цикла, пока не встретим вершину, из которой сможем пойти. В результате получим вершины цикла в обратном порядке.

Реализация алгоритма рекурсивной процедурой:

const
  MaxN = 100;

var
  N : Integer;
  G : array [1 .. MaxN,1 .. MaxN] of Boolean;
  L : array [1 .. MaxN] of Integer;

procedure Euler_Work(A : Integer);
var
  B : Integer;
begin
  B := 1;
  while true do
  begin
    if B<=L[A] then B:=L[A]+1;
    if B>N then break;
    if G[B,A] then
    begin
      L[A] := B;
      Euler_Work(B);
    end;
    Inc(B);
  end;
  Writeln(A);
end;

procedure Euler;
var
  A,B : Integer;
  Found : Boolean;
begin
  Found := false;
  Fillchar(L,sizeof(L),0);
  for A:=1 to N do
  for B:=1 to N do
    if G[A,B] and not Found then
    begin
      Euler_Work(A);
      Found := true;
    end;
end;

Время работы данной реализации O(N2). Алгоритм требует O(M) памяти для хранения стека вызовов процедуры Euler_Work.

Реализация для графа, заданного списками смежности:
(данная реализация требует O(M) времени и O(M) памяти.)

const
  MaxN = 100;
  MaxM = 10000;

type
  TConn = record
    A,B : Integer;
  end;

var
  N,M : Integer;
  GA : array [1 .. MaxN] of Integer;
  GB : array [1 .. MaxM] of TConn;
  W : array [1 .. MaxM] of Byte;
  WS : Integer;

procedure Euler_Work(A : Integer);
var
  B : Integer;
begin
  while GA[A]<>0 do
  begin
    B := GA[A];
    GA[A] := GB[b].B;
    Euler_Work(GB[b].A);
  end;
  Inc(WS);
  W[WS] := A;
end;

procedure Euler;
var
  A,B : Integer;
  Found : Boolean;
begin
  Found := false;
  WS := 0;
  for A:=1 to N do
    if (GA[A]<>0) and not Found then
    begin
      Euler_Work(A);
      Found := true;
    end;
  for A:=WS downto 1 do
    Writeln(W[A]);
end;

Отредактировано Berd (2007-06-20 10:07:28)