Cod sursa(job #1339221)

Utilizator vergilius_beberindeie virgil vergilius_be Data 10 februarie 2015 19:26:28
Problema BFS - Parcurgere in latime Scor 0
Compilator fpc Status done
Runda Arhiva educationala Marime 1.43 kb
program mire;
var f,g:text;
    n,m,s,i,c,ii,j,x,y:longint;
    a:array[1..1000,1..1000] of 0..1;
    co,pred:array[1..10000] of longint;
    viz:array[1..10000] of 0..1;
procedure af(p:integer);
begin
if p<>0 then
  begin
    c:=c+1;
    af(pred[p]);
  end
else
 begin
 if c<>0 then
   write(g,c,' ')
  else
   write(g,'-1',' ');
  end;
end;
procedure bf(nod:longint);
var st,sf,i,d:integer;
  ok:boolean;
begin
  for i:=1 to n do
  viz[i]:=0;
  st:=1;
  sf:=1;
  d:=0;
  viz[s]:=1;
  co[st]:=s;
  pred[1]:=0;
  while st<=sf do
    begin
       for i:=1 to n do
          if (viz[i]<>1) and (a[co[st],i]=1) then
            begin
              inc(sf);
              co[sf]:=i;
              viz[i]:=1;
              pred[sf]:=st;
              if i=nod then
                begin
                 d:=i;
                  break;
                end;
            end;
          if d<>0 then
            break;
            st:=st+1;
    end;
    c:=0;
    af(d);
end;
begin
assign(f,'bfs.in'); reset(f);
assign(g,'bfs.out'); rewrite(g);
   readln(f,n,m,s);
   for i:=1 to m do
    begin
      readln(f,x,y);
      a[x,y]:=1;
    end;
      for ii:=1 to n do
      begin
        if ii=s then
          write(g,'0',' ')
          else
            if a[s,ii]=1 then
              write(g,'1',' ')
        else
         begin
          bf(ii);
        end;
     end;
close(f);
close(g);

end.