Cod sursa(job #1339274)

Utilizator mirelabocsabocsa mirela mirelabocsa Data 10 februarie 2015 19:49:52
Problema BFS - Parcurgere in latime Scor 0
Compilator fpc Status done
Runda Arhiva educationala Marime 1.38 kb
program mire;
var  f,g:text;
 a:array[1..1000,1..1000] of 0..1;
   co,pred:array[1..10000] of longint;
   viz:array[1..10000] of 0..1;
   n,m,i,j,ii,s,x,y,c:longint;
procedure af(d:integer);
begin
 if d<>0 then
   begin
     inc(c);
     af(pred[d]);
   end
 else
  begin
    if c=0 then
      write(g,'-1',' ')
    else
     write(g,c,' ');
  end;
end;
procedure bf(nod:longint);
var st,sf,p:longint;
begin
  st:=1;
  sf:=1;
  for i:=1 to n do
    viz[i]:=0;
  viz[s]:=1;
  co[1]:=s;
  p:=0;
  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;
           pred[sf]:=st;
           viz[i]:=1;
           if i=nod then
             begin
               p:=i;
               break;
             end;
         end;
       st:=st+1;
       c:=0;
        if p<>0 then
          break;
    end;
    af(p);
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 s=ii then
            write(g,'0',' ')
           else
         if a[s,ii]=1 then
           write(g,'1',' ')
          else
           bf(ii);
       end;
  close(f);
  close(g);
end.