Cod sursa(job #1880095)

Utilizator alexandrasirbuAlexandra alexandrasirbu Data 15 februarie 2017 14:50:17
Problema BFS - Parcurgere in latime Scor 100
Compilator fpc Status done
Runda Arhiva educationala Marime 1.8 kb
    type lista=^element;
         element=record
             i:longint;
             a:lista;
                 end;
     
    var ultim,c,p:lista;
        l:array[1..1000001] of longint;
        v:array[1..1000001] of lista;
        i,d,n,m,s,a,b:longint;
        fi, fo: text;
        Bufin,Bufout : Array[1..10000] of byte;
    procedure bfs(s,d:longint);
     
    var w:lista;
    begin
     p:=v[s];
     while p<>nil do
     begin
      if (l[p^.i]=-1)or(l[p^.i]>d) then begin
                                         l[p^.i]:=d;
                                         new(w);
                                         w^.i:=p^.i;
                                         w^.a:=nil;
                                         ultim^.a:=w;
                                         ultim:=w;
                                        end;
      p:=p^.a;
     end;
     if c<>nil then begin
                     c:=c^.a;
                     if c<>nil then bfs(c^.i,l[c^.i]+1);
                     end;
    end;
     
    begin
       assign(fi,'bfs.in'); reset(fi);
       assign(fo,'bfs.out'); rewrite(fo);
       SetTextBuf(fi,Bufin);
       SetTextBuf(fo,Bufout);
       readln(fi,n,m,s);
       for i:=1 to n do begin
                         v[i]:=nil;
                         l[i]:=-1;
                        end;
       l[s]:=0;
       for i:=1 to m do begin
                         readln(fi, a,b);
                         new(p);
                         p^.i:=b;
                         p^.a:=v[a];
                         v[a]:=p;
                        end;
     
       close(fi);
     
       new(p); p^.i:=s; p^.a:=nil; c:=p; ultim:=p;
       d:=1;
       bfs(s,d);
     
       for i:=1 to n do
             write(fo, l[i],' ');
       close(fo);
    end.