Cod sursa(job #260508)

Utilizator batracorina dijmarescu batra Data 17 februarie 2009 09:43:18
Problema Componente tare conexe Scor 30
Compilator fpc Status done
Runda Arhiva educationala Marime 1.71 kb
const nmax=25000;
var a,a2:array[1..nmax,0..100] of 0..1;
    viz1,viz2:array[1..nmax] of word;
    p,j,l,k,nc,i,s,n,x,y:longint;
    m:longint;
    f,g:text;
    ok:boolean;
procedure DF(x:longint);
var i:integer;
begin
  viz1[x]:=p;
  for i:=1 to a[x,0] do
    if (viz1[a[x,i]]=0) then DF(a[x,i]);
end;
procedure DF2(x:longint);
var i:integer;
begin
  viz2[x]:=p;
  for i:=1 to a2[x,0] do
    if (viz2[a2[x,i]]=0) then DF2(a2[x,i]);
end;

begin
  assign(f,'ctc.in');
  reset(f);
  readln(f,n,M);
  for i:=1 to m do
  begin
  readln(f,x,y);
  a[x,0]:=a[x,0]+1;
  a[x,a[x,0]]:=y;
  a2[y,0]:=a2[y,0]+1;
  a2[y,a2[y,0]]:=x;
  end;

  close(f);
  assign(g,'ctc.out');
  nc:=1;
  p:=0;
  x:=1;
  repeat
        ok:=true;
        p:=p+1;
        DF(x);
        DF2(x);
        for i:=1 to n do
            if (viz1[i]=viz2[i])and (viz1[i]=p) then
                                         begin
                                         k:=k+1;
                                         l:=i;
                                         end
                                    else
                                     if (viz1[i]=p) or (viz2[i]=p)then begin
                                       viz1[i]:=0;
                                       viz2[i]:=0;
                                       end;

        for i:=1 to n do
            if viz1[i]=0 then begin
               ok:=False;
               x:=i;
               nc:=nc+1;
               break;
            end;

  until ok;
  rewrite(g);
  writeln(g,nc);
  for i:=1 to nc do
    begin
    p:=i;
    for j:=1 to n do
       if viz1[j]=p then
                  write(g,j,' ');
    writeln(g);
    end;
  close(g);
End.