Cod sursa(job #281386)

Utilizator valytgjiu91stancu vlad valytgjiu91 Data 14 martie 2009 19:24:01
Problema Componente tare conexe Scor 30
Compilator fpc Status done
Runda Arhiva educationala Marime 1.79 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])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.