1. Заголовок темы должен быть информативным. В противном случае тема удаляется ... 2. Все тексты программ должны помещаться в теги [code=pas] ... [/code], либо быть опубликованы на нашем PasteBin в режиме вечного хранения. 3. Прежде чем задавать вопрос, см. "FAQ", если там не нашли ответа, воспользуйтесь ПОИСКОМ, возможно такую задачу уже решали! 4. Не предлагайте свои решения на других языках, кроме Паскаля (исключение - только с согласия модератора). 5. НЕ используйте форум для личного общения, все что не относится к обсуждению темы - на PM! 6. Одна тема - один вопрос (задача) 7.Проверяйте программы перед тем, как разместить их на форуме!!! 8.Спрашивайте и отвечайте четко и по существу!!!
Как обойтись без меток?, потому что работает не корректно...
Занимаюсь изучение графов... так вот нашла подходящую программку,переделала ее под свои нужды...только вот никак не могу избавиться от меток, так как нужно соорудить процедуру, а там метка, и паскаль ругается и работать ни в какую не хочет.Может можно как-нибудь обойтись без нее? при ее удалении выводит повторные точки..
Код
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.
теперь он мне рожицы рисует... а чиво с ними делать , я не знаю... пыталась все как у людей сделать, сообщения об ошибках и все прочее... вот теперь, когда матрицу не правильно вводишь, то рисует рожицы и потом так же менюшку рисует с рожами по второму разу. Я приблизительно догадываюсь , что дело тут в окнах, вернее в их размерах.Вот что получилось
Код:(Показать/Скрыть)
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;
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 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;
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.