Cod sursa(job #260476)

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

begin
  assign(f,'ctc.in');
  reset(f);
  readln(f,n,M);
  for i:=1 to m do
      begin
      read(f,x,y);
      a[x,y]:=1;
      end;
  close(f);
  assign(g,'ctc.out');
  nc:=0;
  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;
        if k=1 then begin
                      viz1[l]:=0;
                      viz2[l]:=0;
                      p:=p-1;
                      end
                else nc:=nc+1;

        for i:=1 to n do
            if viz1[i]=0 then begin
               ok:=False;
               x:=i;
               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.