Cod sursa(job #553686)

Utilizator david93Demeny David david93 Data 14 martie 2011 11:23:23
Problema Componente tare conexe Scor 30
Compilator fpc Status done
Runda Arhiva educationala Marime 1.18 kb
uses crt;
type
 kl=array[1..5000,1..5000] of byte;
 op=array[1..5000] of byte;
var
 i,i2,m,n,a,b,c,d,i3:integer;
 f,g:text;
 x,x1:kl;
 j,j1,j2:op;
procedure lep1(a:integer);
var i:integer;
begin
  j[a]:=1;
  for i:=1 to n do
   if (x[a,i]<>0)and(j[i]<>1) then lep1 (i);
end;
procedure lep2(a:integer);
var i:integer;
begin
 if j[a]=1 then j[a]:=3
 else j[a]:=2;
 for i:=1 to n do
  if (x[i,a]<>0)and(j[i]<2) then lep2(i);
end;
procedure keres(a:integer);
var i:integer;
begin
 x1[d,c]:=a;
 for i:=1 to n do
  if (x[a,i]<>0)and(j[i]=3)and(j1[i]=0)
   then begin inc(c);x[a,i]:=0;j1[i]:=1; keres(i);end
end;
begin
 assign(f,'ctc.in');
 reset(f);
 assign(g,'ctc.out');
 rewrite(g);
 readln(f,n,m);
 for i:=1 to m do
  begin
   readln(f,a,b);
   x[a,b]:=1;
  end;
 for i:=1 to n do
  if j1[i]=0
  then
   begin
    j1[i]:=1;
    lep1(i);
    lep2(i);
    c:=1; inc(d);
    keres(i);
    for i3:=1 to c do
     for i2:=1 to n do
       x[i2,x1[d,i3]]:=0;
    j:=j2;
   end;
 writeln(g,d);
 for i:=1 to d do
  begin
    i2:=1;
    while x1[i,i2]<>0 do
     begin write(g,x1[i,i2],' ');inc(i2); end;
    writeln(g);
  end;
 close(g);
 close(f);
end.