Listing: RETELE.PAS  
{$M 65520,0,655360} 
 const max=6400; 
 type lmuchie=^muchie; 
 muchie=record v1,v2:Integer; 
 u:lmuchie 
 end; 
 vecint=array[0..max] of Integer; 
 var adiac,comp:array[0..max] of ^vecint;    
 n,ncomp:Integer; 
 procedure parcurge; 
 var ndf:Integer; 
 s,s2:lmuchie; 
 tata,nrdf,v:vecint; 
 procedure bloc(i:Integer); 
 var j:Integer; 
 procedure componenta; 
 var k:Integer; 
 prezenti,pointeri:vecint; 
 procedure baga(x:Integer); 
 begin 
 if (pointeri[x]<1) or 
 (pointeri[x]>prezenti[0]) or 
 (prezenti[pointeri[x]]<>x) 
 then begin 
 Inc(prezenti[0]); 
 prezenti[prezenti[0]]:=x; 
 pointeri[x]:=prezenti[0] 
 end; 
 end; 
 
 begin 
 prezenti[0]:=0; s2:=s; 
 repeat 
 baga(s2^.v1); baga(s2^.v2); 
 if (s2^.v1=i) and (s2^.v2=j) 
 then Break; 
 s2:=s2^.u; 
 until false; 
 s:=s2^.u; Inc(ncomp); 
 getmem(comp[ncomp],(prezenti[0]+1)* 
 Sizeof(Integer)); 
 Move(prezenti,comp[ncomp]^, 
 (prezenti[0]+1)*Sizeof(Integer)) 
 end; 
 
 var k:Integer; 
 begin 
 Inc(ndf); nrdf[i]:=ndf; v[i]:=ndf; 
 for k:=1 to adiac[i]^[0] do 
 begin 
 j:=adiac[i]^[k]; 
 if (nrdf[i]>nrdf[j]) and (j<>tata[i])    
 then begin 
 New(s2); 
 s2^.v1:=i; s2^.v2:=j; 
 s2^.u:=s; s:=s2 
 end; 
 if nrdf[j]=0 
 then begin 
 tata[j]:=i; bloc(j); 
 if v[i]>v[j] then v[i]:=v[j]; 
 if v[j]>=nrdf[i] 
 then componenta 
 end 
 
else
 if v[i]>nrdf[j] 
 then v[i]:=nrdf[j] 
 end 
 end; 
 var i:Integer; 
 begin 
 ncomp:=0; ndf:=0; s:=nil; 
 for i:=0 to n-1 do 
 begin 
 nrdf[i]:=0; v[i]:=0; tata[i]:=-1 
 end; 
 for i:=0 to n-1 do 
 begin 
 if nrdf[i]=0 then bloc(i); 
 if adiac[i]^[0]=0 
 then begin 
 Inc(ncomp); 
 Getmem(comp[ncomp],2* 
 Sizeof(Integer)); 
 comp[ncomp]^[0]:=1; 
 comp[ncomp]^[1]:=i 
 end 
 end 
 end; 
 
 procedure afiseaza; 
 var perm:array[1..max] of Integer;    
 procedure qsortcomp(l,r:Integer); 
 var i,j,x,y:integer; 
 begin 
 if l<r 
 
then
 begin
 i:=l; j:=r; 
 x:=comp[ncomp]^[l+random(r-l+1)]; 
 repeat 
 while comp[ncomp]^[i]<x do Inc(i);    
 while x<comp[ncomp]^[j] do Dec(j);    
 if i<=j 
 
then
 begin
 y:=comp[ncomp]^[i]; 
 comp[ncomp]^[i]:=comp[ncomp]^[j]; 
 comp[ncomp]^[j]:=y; 
 Inc(i); Dec(j) 
 end 
 until j<i; 
 qsortcomp(l,j); 
 qsortcomp(i,r) 
 end 
 end; 
 
 procedure qsortperm(l,r:Integer); 
 var i,j,x,y:Integer; 
 begin 
 if l<r 
 
then
 begin
 i:=l; j:=r; 
 x:=comp[perm[l+random(r-l+1)]]^[1]; 
 repeat 
 while comp[perm[i]]^[1]<x do Inc(i);    
 while x<comp[perm[j]]^[1] do Dec(j);    
 if i<=j 
 
then
 begin 
 y:=perm[i]; 
 perm[i]:=perm[j]; 
 perm[j]:=y; 
 Inc(i); Dec(j) 
 end; 
 until j<i; 
 qsortperm(l,j); 
 qsortperm(i,r) 
 end; 
 end; 
 var i,j:Integer; 
 begin 
 for ncomp:=1 to ncomp do 
 begin 
 qsortcomp(1,comp[ncomp]^[0]); 
 perm[ncomp]:=ncomp 
 end; 
 qsortperm(1,ncomp); 
 writeln(ncomp,' sub-retele'); 
 for i:=1 to ncomp do 
 begin 
 for j:=1 to comp[perm[i]]^[0] do    
 Write(comp[perm[i]]^[j],' '); 
 Writeln 
 end; 
 Writeln 
 end; 
 
 var i,j,nr,k,tz:Integer; 
 ch:Char; 
 s:string; 
 h:pointer; 
 
 Begin 
 Assign(input,'C.DAT'); Reset(input); 
 while not SeekEof do 
 begin 
 Read(n); mark(h); 
 for tz:=1 to n do 
 begin 
 Read(i); 
 if SeekEof then; 
 Read(ch); 
 s:=''; 
 repeat 
 Read(ch); 
 if Ch in ['0'..'9'] 
 then s:=s+ch; 
 until not (ch in ['0'..'9']); 
 while ch<>')' do Read(ch); 
 Val(s,nr,k); 
 Getmem(adiac[i],(1+nr)*Sizeof(Integer)); 
 adiac[i]^[0]:=nr; 
 for j:=1 to nr do Read(adiac[i]^[j])    
 end; 
 parcurge; afiseaza; 
 Release(h) 
 end; 
 Close(input) 
 End.