Как обойтись без меток?, потому что работает не корректно... Опции

[LOVE133]

Занимаюсь изучение графов... так вот нашла подходящую программку,переделала ее под свои нужды...только вот никак не могу избавиться от меток, так как нужно соорудить процедуру, а там метка, и паскаль ругается и работать ни в какую не хочет.Может можно как-нибудь обойтись без нее? при ее удалении выводит повторные
точки..

Код

PROGRAM F_i_x_C_o_n_t;
label Metka;
const MaxNodes = 5;
      Stepen = 10;
type NodePtr = 1..MaxNodes;
     Param = 1..Stepen;
     Element = 0..1;
     AdjMatrix = Array [NodePtr,NodePtr] of Element;
     JoinAdj = Array [Param] of AdjMatrix;
var Adj : AdjMatrix; { Матрица смежностей }
    AdjN : JoinAdj; { Массив степеней матрицы смежностей }
    C : AdjMatrix; { Рабочий массив }
    i,j,k: NodePtr; { Параметры циклов }
    n,l,m: Param;
{ --------------------------------------------- }
PROCEDURE P_o_w_e_r (n: Integer; A: AdjMatrix;var C: AdjMatrix);
{ Матрица C получает значение n-й степени матрицы A }
var Z : AdjMatrix;
    Val : Element;
    i,j,k,m: Integer;
BEGIN
   C:=A;
   For m:=1 to n-1 do
   begin
      For i:=1 to MaxNodes do
      For j:=1 to MaxNodes do
      begin
         Val:=0;
         For k:=1 to MaxNodes do
         Val:=Val OR (A[i,k] AND C[k,j]);
         Z[i,j]:=Val
      end;
      C:=Z
   end
END;
{ --- }
BEGIN
   { Ввод матрицы смежностей заданного графа }
   WriteLn ('Вводите элементы матрицы смежностей по стро-кам:');
   For i:= 1 to MaxNodes do
   For j:= 1 to MaxNodes do
   begin
      Write ('Введите Adj[',i,',',j, ']: ');
      ReadLn (Adj[i,j])
   end;
   { Вычисление степеней матрицы смежностей }
   For l:=1 to Stepen do
   begin
      P_o_w_e_r (l,Adj,C);
      For i:= 1 to MaxNodes do
      For j:= 1 to MaxNodes do AdjN [l,i,j]:=C[i,j]
   end;
   Write ('Вводите длину контура: '); ReadLn (n);
   { Отыскание контуров заданной длины }
   For m:=2 to n do
   begin
      For i:=1 to MaxNodes do
      If AdjN [m,i,i]=1
      { Вершина i принадлежит контуру длины n }
      then
      begin
       if m=n then
       begin
         Write ('Вершина ',i,'образует контуры длины ',m, ' с вершинами из множества:{');
         For j:=1 to MaxNodes do
         begin
            If AdjN[m,j,j]=1
            { Вершина j принадлежит }
            { контуру длины m }
            then For l:=1 to m do
            If (AdjN[l,i,j]=1) AND (m-l>0) AND (AdjN[m-l,j,i]=1)
            then
            begin
               Write (j,' '); GoTo Metka
            end;
            Metka:
         end;
         WriteLn ('}')
      end;
      end;
         WriteLn;
   end;
readln;
END.

пример матрицы
0 0 1 1 0
0 0 0 1 1
1 0 0 0 1
1 1 0 0 0
0 1 1 0 0
длина цикла - 5

[klem4]

без метки по идее так :

 For j:=1 to MaxNodes do
         begin
            If AdjN[m,j,j]=1
            { Вершина j принадлежит }
            { контуру длины m }
            then For l:=1 to m do
            If (AdjN[l,i,j]=1) AND (m-l>0) AND (AdjN[m-l,j,i]=1)
            then
            begin
               Write (j,' '); GoTo Metka
            end;
            Metka:
         end;

меняем на

for j := 1 to MaxNodes do
 if AdjN[m,j,j]=1 then begin
   l := 1;
   while (l <= m) and NOT ( (AdjN[l,i,j]=1) AND (m-l>0) AND (AdjN[m-l,j,i]=1) ) do inc(l);
   if l <= m then write(j, ' ');
 end;

[volvo]

Может можно как-нибудь обойтись без нее? при ее удалении выводит повторные точки..

Просто так метку удалять нельзя, иначе действительно будут повторные точки (метка-то введена как раз для их отсечения)... Попробуй так: Описание метки удалить, вместо Goto Metka; поставь Break;, и саму метку тоже удали...

Break как раз и делает то же самое, что и твоя Metka - прекращает выполнение цикла, и выходит на следующую за этим циклом инструкцию...

[LOVE133]

Большое вам спасибо...может если время есть, поможете немного с алгоритмом...потому как писать свое гораздо проще , чем расшифровывать соседское.С трудом воспринимаю кусок про создание массива матрицы, возведенной в разные степени.

begin
         Val:=0;
         For k:=1 to MaxNodes do
         Val:=Val OR (A[i,k] AND C[k,j]);
         Z[i,j]:=Val
      end;

еще интересный вопрос о том , по какому принципу определяется принадлежность точки контуру.Евстигнеева помню (использование матрицы смежности, и матриц в степени к и к-1 елси путь длиной к).ТОлько вот не очень понятно как этот алгоритм реализуется вот в этом куске программы

begin
         Write ('Вершина ',i,'образует контуры длины ',m, ' с вершинами из множества:{');
         For j:=1 to MaxNodes do
         begin
            If AdjN[m,j,j]=1
            { Вершина j принадлежит }
            { контуру длины m }
            then For l:=1 to m do
            If (AdjN[l,i,j]=1) AND (m-l>0) AND (AdjN[m-l,j,i]=1)
            then
            begin 
               Write (j,' '); GoTo Metka
            end;
            Metka:
         end;

[volvo]

С трудом воспринимаю кусок про создание массива матрицы, возведенной в разные степени.

begin
         Val:=0;
         For k:=1 to MaxNodes do
         Val:=Val OR (A[i,k] AND C[k,j]);
         Z[i,j]:=Val
      end;

Ну, если принять что элементами матрицы могут быть только 0 или 1, то такая запись возведения матрицы в степень аналогична этому:

begin
  Val:=0;
  For k:=1 to MaxNodes do
    Val:=Val + (A[i,k] * C[k,j]);
  Z[i,j]:=Val
end;

(т.к. логические операци в данном случае эквивалентны арифметическим), что и является правильным алгоритмом... У нас тоже в FAQ-е есть такое
Как вычислить заданный многочлен от матрицы A (см. matrixMult и matrixPower)

[LOVE133]

теперь он мне рожицы рисует... а чиво с ними делать , я не знаю... пыталась все как у людей сделать, сообщения об ошибках и все прочее... вот теперь, когда матрицу не правильно вводишь, то рисует рожицы и потом так же менюшку рисует с рожами по второму разу. Я приблизительно догадываюсь , что дело тут в окнах, вернее в их размерах.Вот что получилось

Код: (Показать/Скрыть)

Program Konturi;
uses dos,crt,graph;
label Metka;
const MaxNodes = 5;
      Stepen = 10;
type NodePtr = 1..MaxNodes;
     Param = 1..Stepen;
     Element = 0..1;
     AdjMatrix = Array [NodePtr,NodePtr] of Element;
     JoinAdj = Array [Param] of AdjMatrix;
var Adj : AdjMatrix; { Матрица смежностей }
    AdjN : JoinAdj; { Массив степеней матрицы смежностей }
    C : AdjMatrix; { Рабочий массив }
    i,j,k: NodePtr; { Параметры циклов }
    z,l,m: Param;
const Namereg:array[1..3]of string[15] =
 ('INPUT_MATRIX',
  'OPEN_READY',
  'EXIT');


 { Adj:array[0..pred(maxnodes),0..pred(maxnodes)]of byte=
  ((0,0,1,1,0),(0,0,0,1,1),(1,0,0,0,1),(1,1,0,0,0),(0,1,1,0,0));}
type  matrica=array[0..pred(maxnodes),0..pred(maxnodes)] of word;
      MatrStep=Array[0 .. pred(Stepen), 0 .. pred(maxNodes), 0 .. pred(maxNodes)] Of Word;
var key:char;
    regime,x,y:integer;
    n:integer;


    name:string;
    flag:boolean;
{Procedure InMatrix(var a:matrica ) ;
 begin
 end;}

procedure Win1(x,y:integer;reg:string;n,m,s:integer);
begin
gotoxy(x,y);
textcolor(n);
textbackground(m);
if length(reg)=4 then
 begin
  writeln('╔════════════╗');
  gotoxy(x,y+1);
  write('║    ');textcolor(s);
  write(reg);textcolor(n);
  writeln( '    ║');gotoxy(x,y+2);
  writeln('╚════════════╝');
end
   else if  length(reg)=12 then
    begin
     writeln('╔════════════╗'); gotoxy(x,y+1);
     write('║'); textcolor(s);
     write(reg); textcolor(n);
     writeln( '║');gotoxy(x,y+2);
     writeln('╚════════════╝');
   end
    else begin
    writeln('╔════════════╗'); gotoxy(x,y+1);
    write('║ ');textcolor(s);
    write(reg);textcolor(n);
    writeln( ' ║');gotoxy(x,y+2);
    writeln('╚════════════╝');
    end;
  textcolor(4);
  textbackground(0);
end;


procedure Menu(var pos:integer);
var i:integer;
  procedure Cursor(on:boolean);
   var r: registers;
    begin
     r.ah:=1;
      if on then begin
        r.ch:=6;
        r.cl:=7;
        end
      else r.ch:=$20;
      intr(16,r);
      end;

     begin
     window(1,1,80,25);
     textbackground(0);
     clrscr;
     textbackground(0);
     clrscr;
     textcolor(7);
     gotoxy(1,1);
     win1(30,4,namereg[1],0,7,0);
     win1(30,8,namereg[2],0,7,0);
     win1(30,12,namereg[3],0,7,0);

     textbackground(0);
     textcolor(4);
     cursor(false);
     win1(30,pos*4,namereg[pos],1,3,7);
      repeat
       textcolor(5);
        textbackground(0);
        gotoxy(20,24);
        write(' -¬ - Вверх/Вниз ENTER-выбор пункта');
        textcolor(4);
       key:=readkey;
       if ord(key)<>13 then
        begin
          if ord(key)=0 then
            begin
            key:=readkey;
            if ord(key)=80
             then if pos=3 then
             begin win1(30,3*4,namereg[3],0,7,0); pos:=1 end
             else begin win1(30,4*pos,namereg[pos],0,7,0);pos:=pos+1;end
               else if ord(key)=72 then if pos=1 then
                begin win1(30,4,namereg[1],0,7,0);pos:=3 end
                 else begin win1(30,4*pos,namereg[pos],0,7,0); pos:=pos-1;end;
            end;
          textbackground(8);
          textcolor(1);
          win1(30,pos*4,namereg[pos],1,3,7);
          end;
       until key=chr(13);
       WINDOW(1,1,80,25);
       cursor(true);
       textbackground(0);
       textcolor(4);
       clrscr;
       end;

procedure Win_input(name:string);
begin
textbackground(black);
clrscr;
textcolor(blue);
textbackground(7);
window(25,10,75,15);
writeln('╒══',name,'   ══╕');
writeln('│                               │');
writeln('╘═══════════════════════════════╛') ;
gotoxy(2,2);
{textcolor(7);
textbackground(0);
window(1,1,80,25);}

end;
procedure Win_output( name:string);
begin
textbackground(black);
clrscr;
textcolor(red);
textbackground(18);
window(25,10,75,15);
writeln('┌──────────────────────────────┐') ;
writeln('│',name,'│');
writeln('└──────────────────────────────┘');
gotoxy(5,2);
textcolor(7);
textbackground(0);
{window(1,1,80,25);}
end;

Procedure  WinText(n:integer;var a:AdjMatrix);
var i,j:integer;
begin
window(15,2,75,20);
textbackground(black);
clrscr;
textcolor(red);
textbackground(15);
 writeln('█▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀█');
 writeln('█        INPUT MAtRiX on LiNE      █');
 writeln('█▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄█');
 textcolor(green);
 textbackground(black);
 writeln;
  write('█');

 for i:=1 to n*2 do write('▀');  write('█');
 x:=wherex;
 writeln;
 for i:=1 to n+1 do
 begin
 write('█');gotoxy(x-1,4+i);
 write('█');
 writeln;
 end;
  write('█');
 for i:=1 to n*2 do write('▄');  write('█');

 gotoxy(2,6);
 for i:=0 to Pred( n) do
  for j:=0 to Pred( n) do
  begin
   read(a[i,j]);
   gotoxy(2,7+i);
  end;
window(1,1,80,25);


end;

Procedure VVod_Matrix(var n:integer); {Vvodim matricy smegnocti dlya grapha}
var i,j:integer;
begin
 Win_input('INPUT   SIZE  of MATRIX:');
  repeat
  readln(n);
  if n<2 then
   begin
    Win_output('        Repeat Input!         ') ;
    readln;
   end;
  Win_input('INPUT   SIZE  of MATRIX:');
  until n>=2;
end;


Function Proverka_Matrici( a: AdjMatrix; n:integer):boolean;
var i,j:integer;
    flag:boolean;
begin
 Proverka_Matrici:=false;
 flag:=false;
  for i:=1 to n  do
  begin
   for j:=1 to n do
    begin
    if (a[i,j]<>1) and (a[i,j]<>0) then
      begin
      Proverka_Matrici:=true;
      flag:=true;
      break;
      end;
    end;
   if flag then break;
  end;
 end;

Function Proverka_Simmetri4nost(a:  AdjMatrix;n:Integer):boolean;
var i,j:integer;
    flag:boolean;
begin
  Proverka_Simmetri4nost:=false;
  flag:=false;
 for i:=1 to n do
  begin
  for j:=1 to n do
   if a[i,j]<>a[j,i] then
    begin
     flag:=true;
     break;
    end;
   if flag then break;
   end;
  if flag then Proverka_Simmetri4nost:=true ;
end;

Procedure Open_Matrix( var a:  AdjMatrix; name:string; var n:integer; var Flag:boolean);
var i,j:integer;
    f:text;
begin
 flag:=false;
 assign(f,name);
 {$i-}
  reset(f) ;
  {$i+}
  if ioresult<>0 then
  begin
    Win_Output('       File not Found!        ');
    flag:=true;
    readln;
  end
   else
    begin
   for i:=1 to n do
    for j:=1 to n do
      read(f,a[i,j]);
     end;
    end;

Procedure Vivod_Matrix( a:  AdjMatrix;n:integer);
var i,j:integer;
begin
 window(15,2,75,20);
textbackground(black);
clrscr;
textcolor(red);
textbackground(15);
 writeln('█▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀█');
 writeln('█        Vot Vawa Matrica :        █');
 writeln('█▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄█');
 textcolor(green);
 textbackground(black);
 writeln;
 for i:=1 to n do
 begin
  for j:=1 to n do
   write( a[i,j],'  ');
   writeln;
 end;
 end;

PROCEDURE P_o_w_e_r (n: Integer; A: AdjMatrix;var C: AdjMatrix);
{ Матрица C получает значение n-й степени матрицы A }
var Z : AdjMatrix;
    Val : Element;
    i,j,k,m: Integer;
BEGIN
   C:=A;
   For m:=1 to n-1 do
   begin
      For i:=1 to MaxNodes do
      For j:=1 to MaxNodes do
      begin
         Val:=0;
         For k:=1 to MaxNodes do
         Val:=Val OR (A[i,k] AND C[k,j]);
         Z[i,j]:=Val
      end;
      C:=Z
   end
END;

Procedure Made(adj:AdjMatrix;maxnodes:integer);
var l,i,j:integer;
    n:integer;
begin
For l:=1 to Stepen do
   begin
      P_o_w_e_r (l,Adj,C);
      For i:= 1 to MaxNodes do
      For j:= 1 to MaxNodes do AdjN [l,i,j]:=C[i,j]
   end;
   Write ('Вводите длину контура: '); ReadLn (n);
   { Отыскание контуров заданной длины }
   For m:=2 to n do
   begin
      For i:=1 to MaxNodes do
      If AdjN [m,i,i]=1
      { Вершина i принадлежит контуру длины n }
      then
      begin
       if m=n then
       begin
         Write ('Вершина ',i,'образует контуры длины ',m, ' с вершинами из множества:{');
         For j:=1 to MaxNodes do
         begin
            If AdjN[m,j,j]=1
            { Вершина j принадлежит }
            { контуру длины m }
            then For l:=1 to m do
            If (AdjN[l,i,j]=1) AND (m-l>0) AND (AdjN[m-l,j,i]=1)
            then
            begin
               Write (j,' ');  break;
            end;
         end;
         WriteLn ('}');
      end;
      end;
         WriteLn;
   end;
   readln;end;
Procedure OWIBKA;
var i,j,k:integer;
 begin
 clrscr;
  textbackground(9);
  textcolor(13);
  gotoxy(25,8);
  writeln('╒════════════════════════════╕');   gotoxy(25,9);
  writeln('│ Ваша Матрица не подходит ! │');   gotoxy(25,10);
  writeln('│      Повторите ввод!       │');    gotoxy(25,11);
  Writeln('╘════════════════════════════╛');
  gotoxy(47,10);
  readln;

 end;


begin
regime:=1;
 repeat
 menu(regime);
 case regime of
 1:begin
 VVod_Matrix(n);
 Wintext(n,Adj);
 if not Proverka_Matrici(Adj,n) and not Proverka_Simmetri4nost(Adj,n) then
 begin
 Made(adj,n);
 readln;
 end
  else
   begin
    Owibka;

  end;
 end;
 2:begin
  Win_input(' Vvedite imya faila:    ');
  readln(name);
  Win_input('Vvedite razmer matrici: ');
  readln(n) ;
  textbackground(Black);
  window(1,1,80,25);
  textcolor(15);

  Open_Matrix( adj, name, n,flag);
  Vivod_Matrix( adj,n);
   if not Proverka_Matrici(Adj,n) and not Proverka_Simmetri4nost(Adj,n) and not flag then
 begin
Made(adj,n);
 readln;
 end
 else owibka;
 end;
 3:begin
  owibka;
 end;
 end;
 until regime=3;
end.

[volvo]

Проблема даже не в окошках... Смотри, что происходит:

type
  NodePtr = 1..MaxNodes; { <--- Заметь, от 1 до MaxNodes, а не от 0 }
  Param = 1..Stepen;
  Element = 0..1;
  AdjMatrix = Array [NodePtr,NodePtr] of Element;

Уже здесь:

Procedure  WinText(n:integer; var a:AdjMatrix);
...
  for i:=0 to Pred( n) do
    for j:=0 to Pred( n) do
    begin
      read(a[i,j]); { На первой же итерации - попытка чтения A[0, 0] }
      gotoxy(2,7+i);
    end;
...

у тебя будет неверный ввод данных (в частности - выход за границы массива).

[LOVE133]

(*бъет себя по лбу,сильно , сильно*)
переделать, все переделала, а сохранить забыла...
там нужно с 1... это от старой версии осталось, но там и массив с 0 начинался...
пасип...