Przeszukiwanie w glab

0

Witam

Pisze program przeszukujacy graf w glab, ale ma problem - gdzies w tej procedurze:

procedure szukaj(var stos: wsk; var kolor: tabkol; lista: tab; licz: integer);

 var
  a,j,i: integer;
  pom: wsk;

 begin
  writeln('Podaj szukany wierzcholek: ');
  readln(a);

  j:=1;

  for i:=1 to licz do
   kolor[i]:='b';

  new(stos);
  stos^.dane:=1;
  stos^.nast:=nil;

  kolor[1]:='s';

  writeln('Lista sasiedztwa: ');
  writeln;
  wypiszl(lista,licz);
  writeln('Stany stosu i tabeli kolorow po kolejnych operacjach: ');
  writeln;

  wypiszstos(stos);
  wypiszkolor(kolor);
  writeln('==============================');

  while stos^.dane <> a do
   begin
    if kolor[lista[j]^.dane] = 'b' then
     begin
      new(pom);
      pom^.dane:=lista[j]^.dane;
      pom^.nast:=stos;
      stos:=pom;
      j:=lista[j]^.dane;
      kolor[j]:='s';
     end
    else if kolor[lista[j]^.dane] = 's' then
     begin
      while (kolor[lista[j]^.dane] <> 'b') or (lista[j] <> nil) do
       lista[j]:=lista[j]^.nast;
        if lista[j] = nil then
         begin
          kolor[j]:='c';
          new(pom);
          pom:=stos^.nast;
          dispose(stos);
          stos:=pom;
          j:=stos^.dane;
         end
        else if kolor[lista[j]^.dane] = 'b' then
         begin
          new(pom);
          pom^.dane:=lista[j]^.dane;
          pom^.nast:=stos;
          stos:=pom;
          j:=lista[j]^.dane;
          kolor[j]:='s';
         end;
     end
    else if kolor[lista[j]^.dane] = 'c' then
     begin
      new(pom);
      pom:=stos^.nast;
      dispose(stos);
      stos:=pom;
      j:=stos^.dane;
     end;
    wypiszstos(stos);
    wypiszkolor(kolor);
    writeln('==============================');
   end;
  writeln;
  writeln('Droga do szukanego wierzcholka: ');
  wypiszdroge(stos);
  readln;
 end;

jest blad, ktorego nie moge zlokalizowac.

Konkretnie wywala sie gdzies w tym fragmencie:

else if kolor[lista[j]^.dane] = 's' then
     begin
      while (kolor[lista[j]^.dane] <> 'b') or (lista[j] <> nil) do
       lista[j]:=lista[j]^.nast;
        if lista[j] = nil then
         begin
          kolor[j]:='c';
          new(pom);
          pom:=stos^.nast;
          dispose(stos);
          stos:=pom;
          j:=stos^.dane;
         end
        else if kolor[lista[j]^.dane] = 'b' then
         begin
          new(pom);
          pom^.dane:=lista[j]^.dane;
          pom^.nast:=stos;
          stos:=pom;
          j:=lista[j]^.dane;
          kolor[j]:='s';
         end;

Czy moge liczyc na podpowiedz co jest nie tak? ;)

b,s,c to kolory wierzcholkow - biale to nieodwiedzone, szare to odwiedzone, ale majace jeszcze nieodwiedzonych sasiadow, a czarne to odwiedzone bez nieodwiedzonych sasiadow.

przykladowy plik do wczytania:

1 2
1 5
1 6
2 3
2 4
3 4
5 6

Na wszelki wypadek caly program (kompiluje sie normalnie):

program przeszukiwanie_w_glab;

uses crt;

const
 max = 50;

type
 wsk = ^twsk;
 twsk = record
  dane: integer;
  nast: wsk;
 end;

 tab = array[1..max] of wsk;

 tabkol = array[1..max] of char;

var
 lista: tab;
 t1,t2,licz: integer;
 k: boolean;
 stos: wsk;
 kolor: tabkol;

procedure zamien(var t1,t2: integer);

 var
  a: integer;

 begin
  a:=t1;
  t1:=t2;
  t2:=a;
 end;

procedure dodaj(var lista: tab; var licz: integer; t1,t2: integer);

 var
  pom: wsk;

 begin
  if lista[t1] = nil then
   begin
    new(lista[t1]);
    lista[t1]^.dane:=t2;
    lista[t1]^.nast:=nil;
   end
  else
   begin
    new(pom);
    pom^.dane:=t2;
    pom^.nast:=lista[t1];
    lista[t1]:=pom;
   end;
  if t1 > licz then
   licz:=t1;
 end;

procedure wczytaj(var lista: tab; var t1,t2: integer);

 var
  plik: text;
  t: string;

 begin
  writeln('Podaj nazwe pliku: ');
  readln(t);

  assign(plik,t);
  reset(plik);

  while not eof(plik) do
   begin
    readln(plik,t1,t2);
    dodaj(lista,licz,t1,t2);
    zamien(t1,t2);
    dodaj(lista,licz,t1,t2);
   end;
  close(plik);
 end;

procedure usun(var lista: tab; licz: integer);

 var
  i: integer;
  pom: wsk;

 begin
  for i:=1 to licz do
   begin
    while lista[i] <> nil do
     begin
      pom:=lista[i]^.nast;
      dispose(lista[i]);
      lista[i]:=pom;
     end;
   end;
  licz:=0;
 end;

procedure wypiszl(lista: tab; licz: integer);

 var
  i: integer;

 begin
  for i:=1 to licz do
   begin
    writeln('Sasiedzi wierzcholka ',i,': ');
     while lista[i] <> nil do
      begin
       write('->',lista[i]^.dane);
       lista[i]:=lista[i]^.nast;
      end;
     writeln;
   end;
  readln;
 end;

procedure wypiszstos(stos: wsk);

 begin
  while stos <> nil do
   begin
    write(stos^.dane,'->');
    stos:=stos^.nast;
   end;
  write('nil');
  writeln;
 end;

procedure wypiszdroge(stos: wsk);

 var
  tmp: array[1..max] of integer;
  i,j: integer;

 begin
  i:=1;
  while stos <> nil do
   begin
    tmp[i]:=stos^.dane;
    stos:=stos^.nast;
    i:=i+1;
   end;
  writeln;
  write('START>>');
  for j:=i-1 downto 1 do
   write(tmp[j],'>>');
  writeln('KONIEC');
 end;

procedure wypiszkolor(kolor: tabkol);

 var
  i,j,k: integer;

 begin
  for i:=1 to licz do
   write(i,'|');
  writeln;
  for j:=1 to licz do
   write('--');
  writeln;
  for k:=1 to licz do
   write(kolor[k],'|');
  writeln;
 end;

procedure szukaj(var stos: wsk; var kolor: tabkol; lista: tab; licz: integer);

 var
  a,j,i: integer;
  pom: wsk;

 begin
  writeln('Podaj szukany wierzcholek: ');
  readln(a);

  j:=1;

  for i:=1 to licz do
   kolor[i]:='b';

  new(stos);
  stos^.dane:=1;
  stos^.nast:=nil;

  kolor[1]:='s';

  writeln('Lista sasiedztwa: ');
  writeln;
  wypiszl(lista,licz);
  writeln('Stany stosu i tabeli kolorow po kolejnych operacjach: ');
  writeln;

  wypiszstos(stos);
  wypiszkolor(kolor);
  writeln('==============================');

  while stos^.dane <> a do
   begin
    if kolor[lista[j]^.dane] = 'b' then
     begin
      new(pom);
      pom^.dane:=lista[j]^.dane;
      pom^.nast:=stos;
      stos:=pom;
      j:=lista[j]^.dane;
      kolor[j]:='s';
     end
    else if kolor[lista[j]^.dane] = 's' then
     begin
      while (kolor[lista[j]^.dane] <> 'b') or (lista[j] <> nil) do
       lista[j]:=lista[j]^.nast;
        if lista[j] = nil then
         begin
          kolor[j]:='c';
          new(pom);
          pom:=stos^.nast;
          dispose(stos);
          stos:=pom;
          j:=stos^.dane;
         end
        else if kolor[lista[j]^.dane] = 'b' then
         begin
          new(pom);
          pom^.dane:=lista[j]^.dane;
          pom^.nast:=stos;
          stos:=pom;
          j:=lista[j]^.dane;
          kolor[j]:='s';
         end;
     end
    else if kolor[lista[j]^.dane] = 'c' then
     begin
      new(pom);
      pom:=stos^.nast;
      dispose(stos);
      stos:=pom;
      j:=stos^.dane;
     end;
    wypiszstos(stos);
    wypiszkolor(kolor);
    writeln('==============================');
   end;
  writeln;
  writeln('Droga do szukanego wierzcholka: ');
  wypiszdroge(stos);
  readln;
 end;

procedure usunstos(var stos: wsk);

 var
  pom: wsk;

 begin
  while stos <> nil do
   begin
    pom:=stos^.nast;
    dispose(stos);
    stos:=pom;
   end;
 end;

procedure czysc(var licz: integer);

 begin
  usun(lista,licz);
  usunstos(stos);
  licz:=0;
 end;

begin
 k:=false;
 licz:=0;

 repeat

  clrscr;
  writeln('MENU');
  writeln('1 - Wczytaj liste krawedzi z pliku');
  writeln('2 - Wypisz liste sasiedztwa');
  writeln('3 - Przeszukaj graf');
  writeln('4 - Oczysc pamiec');
  writeln('5 - Zakoncz');
  writeln;

  case readkey of

   '1': wczytaj(lista,t1,t2);
   '2': wypiszl(lista,licz);
   '3': szukaj(stos,kolor,lista,licz);
   '4': czysc(licz);
   '5': k:=true;

  end;

 until k;

 czysc(licz);

end.
0

ja bym zrobil tak

if Assigned(lista[j]) do
  while (kolor[lista[j]^.dane] <> 'b')  do
//nie wiem czy tu chcesz miec begin czy nie?

     lista[j]:=lista[j]^.nast;
        if lista[j] = nil then  // if not Assigned(lista[j])
         begin
          kolor[j]:='c';
          new(pom);
          pom:=stos^.nast;
          dispose(stos);

A przedebugowac nie mozesz?

      stos:=pom;
      j:=stos^.dane;
     end
</delphi>

1 użytkowników online, w tym zalogowanych: 0, gości: 1