Фундоментальные циклы графа

Program GraphCycle; {Фундаментальные циклы графа} 
uses CRT,DOS; 
Const 
nVertex=100; {Максимальное количество вершин} 
nAdjacent=1000; {Максимальная длина списка смежности} 
Туре 
TypeVertex=array[I..nVertex] of Integer; 
TypeAdjacent=array[1..nAdjacent] of Integer; 
{ Текстовый файл } 
{ Количество вершин } 
{ Количество вершин в стеке циклов} 
Var 
f :Text;
n :Integer;
nC :Integer;
Adj :TypeAdjacent; { Список смежности графа } 
Fst :TypeVertex; { Указатели вершин списка смежности} 
Nbr :TypeVertex; { Количество вершин в списке 
смежности } 
Vtx :TypeVertex; { Список вершин графа } 
Mark :TypeVertex; { Номера компонент для вершин графа} 
С :TypeVertex; { Стек выделения циклов графа } 
В :TypeVertex; { Признаки основных и обратных ребер 
прохода в глубину } 
jC :Integer; { Счетчик числа циклов } 
count:Integer; { Счетчик меток вершин } 
Procedure Init( var yes :Boolean ); 
{ Переназначение меток вершин } 
{ их порядковыми номерами в списке смежности } 
{ yes - признак правильной структуры списка смежности } 
Var 
i,j,m -.Integer; 
begin 
for i:=l to n do 
for j:=l to Nbr[i] do begin 
yes:=FALSE; 
for m:=l to n do 
if Adj[Fst[i]+j]=Vtx[m] then begin 
yes:=TRUE; 
Adj[Fst[i]+j]:=m; 
break; 
end; 
if not yes then exit; 
end; 
end; 
Procedure PrintCycle( x:Integer; var С:TypeVertex; 
nC:Integer); {Печать цикла из стека} 
begin 
Write(ffjC,')'); 
repeat 
Write(f,Vtx[C[nC]]:3); 
nC:=nC-l; 
until C[nC]=x; 
Writeln(f); 
end; 
Procedure Cycle( x,у:Integer ); 
Var 
i,v :Integer; 
begin 
 
count:=count+l; 
Mark[x]:=count; 
for i:=l to Nbr[x] do begin 
v:=Adj[Fst[x]+i]; 
nC:=nC+l; C[nC]:=v; 
if Mark[v]=0 then Cycle(v,x) 
else if (Mark[v]<Mark[x]) and (v<>y) then begin 
(Обратное ребро в пройденную вершину - найден цикл} 
PrintCycle(v,C,nC); 
end; 
nC:=nC-l; 
end; 
end; 
Procedure DepthCycle; {Проход в глубину за циклами) 
Var 
v:Integer; 
begin 
jC:=O; {Счетчик числа циклов} 
nC:=0; {С - стек циклов пустой } 
count:=0; {Номер метки вершины} 
for v:=l to n do Mark[v]:=0; 
for v:=l to n do if Mark[v]=0 then begin 
nC:=nC+l; C[nC]:=v; 
Cycle(v,0); 
nC:=nC-l; 
end; 
end; 
Var {Main} 
i,j :Integer; 
yes .-Boolean; 
begin {Main} 
Assign(f,'Cycle.in' ) ; 
Reset(f);{Файл открыт для чтения} 
{Ввод списка смежности} 
Read(f,n); {Количество строк в списке} 
Fst[l]:=0; {Указатель начала первой строки списка} 
for i:=l to n do begin 
Read(f,Vtx[i]); {Метка вершины} 
Read(f,Nbr[i]); {Количество вершин в списке} 
for j:=l to Nbr[i] do Read(f,Adj[Fst[i]+j]); 
{Список смежных вершин} 
Fst[i+1]:=Fst[i]+Nbr[i]; {Указатель начала следующей 
строки в списке} 
 end; 
Close(f); 
Assign(f,'Cycle.out' ) ; 
Rewrite(f); {Файл открыт для записи} 
Init(yes); 
if not yes then begin 
WriteLn(f,'Плохая структура смежности графа!'); 
Close(f) ; 
exit; 
end; 
DepthCycle; 
Close(f); 
end. {Main}