Algorytm Grafowy. BFS cos mi sie wywala

Witam,
napisalem programik BFS, ale cos mi sie wywala. problem tkwi w procedurze BFS. Prosze osoby, ktore znaja ten algorytm, aby rzucily na niego okiem i napisaly mi, gdzie do kodu wkradl mi sie blad, bo po wielu godzinach poszukiwan nie moge go znaleŹĆ, pozdrawiam

program Project1;

{$APPTYPE CONSOLE}

uses
  SysUtils;

const
  N_MAX = 10; // maksymalna ilosc wierzcholkow
  W_MAX = 15; // maksymalna wartosc wierzcholka

  PLIK_IN = 'C:\tmp\grafIN.txt';

type
  TLista = ^TObiekt;
  TObiekt = record
    wart : integer;
    nast : TLista;
  end;

  TGraf = array[1..N_MAX] of TLista;
  TKolor = array[1..N_MAX] of char;
  TWierzWiodacy = array[1..N_MAX] of integer;

  //tablica zawierajaca polaczenia (krawedzie) miedzy wierzcholkami
  TPolaczenie = array[1..W_MAX, 1..W_MAX] of boolean;

var
  x, y : integer;
  i : integer;
  Graf : TGraf;
  Kolor : TKolor;
  Polaczenie : TPolaczenie;
  Glowa, Ogon : TLista;
  WierzWiodacy : TWierzWiodacy;
  szary : integer;
  Licznik : integer;


procedure WczytajZPliku (NazwaPliku : string; var tab : TPolaczenie);
var
   t : text;
   x, y : integer;
begin
     assign(t, NazwaPliku);
     reset(t);
     readln(t, szary);
     while not eof (t) do
       begin
         readln(t, y, x);
         tab[y][x] := true;
       end;
     close(t);
end;

procedure DodajKrawedz(var g : TGraf; y, x : integer);
var
  p : TLista;
begin

  new(p);
  p^.wart := x;
  p^.nast := g[y];
  g[y] := p;

end;

procedure WypiszListe(lista: TLista);
var
  tmp : TLista;
begin
  tmp := lista;
  while tmp <> nil do
    begin
      write(' ->', tmp^.wart);
      tmp := tmp^.nast;
    end;

end;

procedure DodajDoKolejki(Wierzcholek : integer; var Glowa : TLista);
var
  tmp: TLista;
begin

  new(tmp);
  tmp^.wart := Wierzcholek;
  Glowa^.nast := tmp;
  Glowa := tmp;

end;

procedure UsunZKolejki(var Ogon: TLista);
var
  tmp : TLista;
begin
  if Ogon <> nil then
    begin
      tmp := Ogon;
      Ogon := Ogon^.nast;
      dispose(tmp);
    end;
end;


procedure BFS(var Glowa, Ogon: TLista;
              var Graf: TGraf;
              var Kolor: TKolor;
              var WierzWiodacy: TWierzWiodacy;
              var Licznik: integer);
var
  Lista: TLista;
  Wierzcholek: integer;
begin
  while (Glowa <> nil) do
    begin
      Lista := Graf[Glowa^.wart];
      while (Lista <> nil) do
        begin
          Wierzcholek := Lista^.wart;
          writeln('          ', Wierzcholek);
          if (Kolor[Wierzcholek] = 'b') then
            begin
              Kolor[Wierzcholek] := 's';
              WierzWiodacy[Wierzcholek] := Licznik;
              Inc(Licznik);
              writeln('tutaj1');
              DodajDoKolejki(Wierzcholek, Glowa);
              writeln('tutaj11');
            end;
          Kolor[Ogon^.wart] := 'c';
          writeln('tutaj3');
          UsunZKolejki(Ogon);
          writeln('tutaj33');
          Lista := Lista^.nast;
          write('tutaj333     ', Ogon^.wart,   '->');
          WypiszListe(Ogon);
          writeln
        end;

    end;
end;

begin
  WczytajZPliku (PLIK_IN, Polaczenie);

  for x := 1 to W_MAX do
    for y := 1 to W_MAX do
      if Polaczenie[y, x] then DodajKrawedz(Graf, y, x);

  //wypisanie grafu
  for i:=1 to N_MAX do
    if Graf[i] <> nil then
      begin
        write(i, '  ');
        WypiszListe(Graf[i]);
        writeln;
      end;

  for i := 1 to N_MAX do
    Kolor[i] := 'b';
  Kolor[szary] := 's';

  WierzWiodacy[szary] := 1;
  Licznik := 2;

  new(Glowa);
  Ogon := Glowa;
  Glowa^.wart := szary;

  BFS(Glowa, Ogon, Graf, Kolor, WierzWiodacy, Licznik);

  for i :=1 to N_MAX do
    write(Kolor[i], ' ');
  writeln;

  for i := 1 to N_MAX do
    write(WierzWiodacy[i], ' ');

  writeln('asasa');
  readln(licznik);


end.