Найти все пути, соединяющие вершину графа v1 с вершинной с заданным номером m

@krutyash94 · Регистрация: 11.06.2014

Студворк — интернет-сервис помощи студентам

По заданной матрице смежности вершин ориентированного графа найти все пути, соединяющие вершину v₁ с вершинной с заданным номером m.

Исходные данные: количество вершин орграфа, матрица смежности вершин и номер вершины m.

Результаты:

сообщение есть ли пути, соединяющие вершину v₁ с вершиной с заданным номером m;

сообщение есть ли контуры, проходящие через вершину v₁ и вершину с заданным номером m;

все пути, соединяющие вершину v₁ с вершинной с заданным номером m.

Вот что у меня получилось:

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
uses crt;
const n=5; 
 a : array  [1..n,1..n] of byte=(
 (0,1,1,1,1),
 (0,0,1,1,1),
 (0,0,0,1,1),
 (0,0,0,0,0),
 (0,0,0,1,0));
var 
 i,j,k,t,m,x,y,c,s,sn,ss,d,sd,h,f,q,l,v:integer;
 b: array [0..3200]of integer;
 
begin
read(m);x:=1;q:=0;
for i:=2 to n do 
  begin
    if a[1,i]=1 then
     begin
       ss:=ss+1;
       //счетчик спускания(поднимания)матрицы
       c:=c+1;// независимый счетчик записи в массив
       y:=i;// замена строки на столбец
       b[c]:=y;
       x:=2;
         while x<=n+1 do 
          begin
            writeln('3aLLIoJI B IIepBbIu U,ukJI',' x=',x);
           if (y>0)and(y<=n)and(x>1)and (x<=n) then 
            begin 
             if a[y,x] = 1  then
              begin
                 write('Ha4aJIO -  y=',y,'  x=',x,'  c=',c,'  ss=',ss,'  q=',q);for t:=0 to c do write(b[t]:3); writeln;
                 c:=c+1; 
                 b[c]:=x;
                 //ss:=ss+1;                   
                if (x=m)  then 
                   begin
                    if x=n then begin x:=y+1; ss:=ss-1;  y:=b[q+ss-1];end else x:=x+1;
                     c:=c+1;
                     b[c]:=0;
                           h:=c-1;
                           while b[h]<>0 do                     
                              begin
                                 if b[h-1]=0 then q:=h;
                                 h:=h-1;
                              end;
                           for t:=(c+1) to (c+ss) do
                             begin
                               b[t]:=b[q];
                               c:=c+1;
                               q:=q+1;
                             end;
                        q:=q-(ss-1);
                   end else
                      begin
                         y:=x;
                         ss:=ss+1;
                         x:=2;
                      end;
                     
                     if (x=n)and(m<>n )then 
                     begin
                        x:=2;
                        ss:=ss+1;
                        y:=n;
                        
                        
                        
                        
                        
                     end;
                      
                   //if x=m then x:=x+1;        
                 write('KoHeU,  -  y=',y,'  x=',x,'  c=',c,'  ss=',ss,'  q=',q);for t:=0 to c do write(b[t]:3); writeln;
                  
              end;
           if  (y<=n)and(y>0)and(x<=n)and(x>0)and(a[y,x]=0)and(x=n) then
             begin 
              ss:=ss-1;
              if y=n then begin  x:=2; ss:=ss-1; y:=b[q+ss-1];end else begin  y:=b[q+ss-1];x:=y+2; end; 
               c:=c+1; 
                b[c]:=0;
             // for t:=q+ss to c do b[t]:=0;
             // c:=ss+q-1;
              end
             else if (y<=n)and(y>0)and(x<=n)and(x>0)and (a[y,x]=0) then  x:=x+1;
            
                        
            if ss=0 then x:=n+1;
            end;
            
          end;
     end;
   //  write();
  end;
  
  for i:=0 to c do 
  begin
   if i<>0 then if b[i]=0 then writeln;
  write(b[i]:3);
  
  end;
  writeln;
end.

И вот:

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
uses crt;
const n=5; 
 a : array  [1..n,1..n] of byte=(
 (0,0,1,1,1),
 (0,0,0,1,1),
 (0,1,0,1,1),
 (0,0,0,0,1),
 (0,0,0,0,0));
var 
 i,j,k,t,m,x,y,c,s,sn,ss,d,sd,h,f,q,l,v:byte;
 b: array [0..3200,1..3200]of integer;
begin
 
v:=0;
writeln('Введите вершину m: '); readln(m);
write('Пути соединяемые вершины V1 и m - ');
 for j:=1 to m do if a[1,j] = 1 then v:=1;
 for i:=1 to m do if a[i,1] = 1 then v:=1;
 if v=1 then writeln('существуют!') else 
            writeln('НЕ существуют!!!');
 
 sn:=2;ss:=0;d:=0;f:=0;
 while sn<>n+1 do
  begin
   for h:=1 to n do if a[h,sn]=1 then d:=d+1;
   if a[1,sn]=1 then f:=f+1;
  // while a[1,sn-1]<>1 do sd:=sn;
   if d>=2 then ss:=ss+n*(d-1);
   d:=0;
   sn:=sn+1;
  end;
  s:=n*n+ss;
  y:=0;
  k:=1;
writeln;
//write('ss=',ss, ' s=',s,'   f=',f);
writeln;i:=1;d:=0;
for h:=2 to n do if a[i,h]=1 then begin if d<1 then sd:=h; d:=d+1;end;
 
 
   y:=1;
   x:=1;
   t:=1;
   j:=1;
   b[y,1]:=1;
   c:=1;d:=0;
      while c<>s   do
       begin
       
        if (*(x<=n)and(j<=n)and*)(j>1)and (x>0) and (a[x,j]=1) then
        
         begin
         //writeln ('zahod: x=',x,'   j=',j);
          //if x=1 then d:=j;
          
          t:=t+1;
          b[y,t]:=j; 
          c:=c+1;
         //if (y = 1) then  for k:=1 to sd do b[y-1,k]:=b[y,k];
          if j<>1 then
          
            begin
              
              
             if (y>=1)and(t>1) and (x<>b[y-1,t-1]) then
               begin 
                y:=y+1;
                for k:=1 to t do b[y,k]:=b[y-1,k];//y:=y+1;
                
               end else
               begin
               if (t>1)and(y>=1) then
                begin for k:=1 to (t-1) do b[y,k]:=b[y-1,k]; y:=y+1;
                for k:=1 to t do b[y,k]:=b[y-1,k];
                
                end;
                
               end;
             
        
               x:=j;
                j:=1;
                end else 
              begin 
               y:=y+1;  
               t:=t-1;
               j:=j+1;
               c:=c+1;
               
              end;
            
         end   else 
           begin 
             c:=c+1; 
             j:=j+1; 
             
             for i:=1 to n*n do if (y>1) and (b[y,i]=b[y-1,i]) then d:=d+1;
         if d=n*n then begin for i:=1 to n*n do if (y>1) and (b[y,i]=b[y-1,i]) then  b[y,i]:=0; y:=y; end;
         d:=0;
           end;  
        
        if (j=6)and(c=(s-((f-1)*n+(n-sd)))) then begin c:=c+1; x:=1; j:=b[1,sd+1]; t:=x;  end;       
  writeln('j=',j,'  cc=',c,'y=',y,' x=',x);writeln; 
        if (j=6)and(x<>1)  then
 
         begin
                  //c:=c+1;
           if x=n then  begin  j:=1; x:=b[2,2]   end else j:=x+1;
           //j:=x+1;
          x:=b[1,2]; //y:=y+1;
           t:=t-1;
         end;
         
       //if l=50 then begin y:=y+1; l:=50; end;
         
        // if x=b[y,t-1] then begin j:=b[1,d+1]; x:=1;  end;
         //writeln('vyhod x=',x,'   j=',j,'  y=',y,'  t=',t,'  c=',c);
        if (c<20)then   for i:=1 to y do begin for m:=1 to n+1 do begin write(b[i,m]:3);end; writeln(' y=', y) end; 
        writeln;
      end;//while
 
  
  
       for i:=1 to y-1 do
        begin
        for j:=1 to n+1 do
         begin
         write(b[i,j]:3);
         end;
         writeln;
         end;
         q:=0;
      s:=0;l:=0; if v=1 then  writeln('Все пути из вершины V1 в вершину V',m,'(m):'); writeln;
for i:=0 to y do
 begin
  for j:=1 to n+1 do
  begin
  if (m<>1)and(b[i,j]=m)and(b[i,j+1]=0) then
   begin
     for h:=1 to n+1 do if b[i,h]<>0 then q:=q+1;
     for h:=1 to q do write(' V',b[i,h]);
     q:=0;
     writeln;
     //if (j>1)and (b[i,j]=1) then l:=1; write(' mas=',b[i,j]);
   end;
   //if (j<>1)and (b[i,j]=1) then l:=1; //write(' mas=',b[i,j]);
   
   if (m<>1) and(j<>1)and (b[i,j]=1)then for h:=1 to j do if b[i,h]=m then l:=1;
   
   end;
   //for h:=1 to n+1 do if b[i,h]<>0 then s:=s+1;
   //if (s<>0)and(s<=n)and(b[i,s]=1)then l:=l;//write('  b[i,s]=',b[i,s],'  i=',i,'  s=',s);
   //s:=0;
   
   
 end;
writeln; 
   write('Контуры проходящие через вершину V1 и вершину m ');
 if l=1 then writeln('- существуют!') else writeln('- НЕ существуют!!!');
   writeln; 
 
 end.

И такой вариант:

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
uses crt;
const n=5; 
 a : array  [1..n,1..n] of byte=(
 (0,1,1,1,1),
 (0,0,1,1,1),
 (0,0,0,1,1),
 (0,0,0,0,1),
 (0,0,0,0,0));
var 
 i,j,k,t,m,x,y,c,s,sn,ss,d,sd,h,f,q,l,v:integer;
 b: array [1..3200]of integer;
 
begin
read(m);
d:=0;
 for i:= 1 to n do if a[i,m]=1 then d:=d+1;
 l:=0;v:=1;q:=1;i:=1;h:=1;s:=1;j:=1; c:=50;
        while l<>d do
         begin
          for j:=v to n do 
           begin
           write('Ha4aJIo-   i=',i,' j=',j,' h=',h,'  ');for t:=1 to n do write(b[t]);  writeln;
            if  (s>1)and(j=1)and(b[s-1]=1) then 
             begin 
                
                b[s-1]:=0; 
                s:=s-1; 
                //h:=j+1;
             end;
           
            if (j>1)and(c=50)and (a[i,j]=1)and(j<>m) then
              begin  
               c:=100;
               h:=j; 
               b[s]:=j; 
               s:=s+1; 
              end else 
               if ((a[i,j]=1))and (j=m)and (c=50) then 
                  begin 
                   b[s]:=j;
                     s:=s+1;
                   for t:=1 to s-1 do write(b[t]:3);
                   b[s-1]:=0; 
                   s:=s-1;
                   
                   l:=l+1;
                   
                   writeln;
                  end;
           // if (c=50)and(j=n)then begin     end; 
            if (j=n)and(c=50) then begin q:=i+1; b[s-1]:=0; s:=s-1;c:=100; end;
            //if (j=n)and(c=100)and(i=5) then h:=1; c:=100;
            
           { if  (s>1)and(j=1)and(b[s-1]=1) then 
             begin 
                
                b[s-1]:=0; 
                s:=s-1; 
                h:=j+1;
             end;
             
             }
             if (c=50)and(j=n)then begin  b[s-1]:=0; s:=s-1;   end; 
             write('KoHeU, -   i=',i,' j=',j,' h=',h,'  ');for t:=1 to n do write(b[t]);  writeln;
           end;
          v:=1;//write('  b[s]=',b[s],'  s=',s); 
 
          if l<>d then for k:=q to n do 
            begin
            write('2Ha4aJIo   h=',h,' k=',k,' i=',i,'   q=',q,'  ');for t:=1 to n do write(b[t]);  writeln;
             if (k>1)and(c=100)and(a[h,k]=1)and (k<>m) then 
               begin 
                 c:=200;
                 i:=k; 
                 b[s]:=i; 
                 s:=s+1;
                 end else
                 if (k=m)and(a[h,k]=1)and (c=100) then 
                   begin 
                     b[s]:=k;
                     s:=s+1;
                     for t:=1 to s-1 do write(b[t]:3); 
                     b[s-1]:=0; 
                     s:=s-1;
                    if k<>n then i:=k;
                     l:=l+1;
                     
                     writeln;
                   end;
            // if (k=n)and(c=100) then v:=i;
             if (s>1)and(k=1)and(b[s-1]=1)then 
              begin 
              
               b[s-1]:=0;
               s:=s-1; 
              // i:=i; 
              end;
              write('2KoHeu,-   h=',h,' k=',k,' i=',i,'   q=',q,'  ');for t:=1 to n do write(b[t]);  writeln;
          
            end;
           q:=1; c:=50; //writeln; writeln(' mas=',b[s],' s=',s,'  l=',l);
            
         end;
      
   
   //end;
 
 
 
 
end.

Везде недочеты незнаю что делать.. подскажите кто нибудь..

@krutyash94 · 22.06.2014, 20:48 **[ТС]**

Все получилось, другой вариант работает:

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
program practika_variant_N_8;
uses crt;
var
 m,n,i,j,t,y,x,p,s:byte;
 a : array [1..255,1..255] of byte;
 b : array [1..255,1..255] of byte;
 begin
  write('Введите размер матрицы: ');
  readln(n);
  writeln('Введите матрицу смежности: '); 
  for i:=1 to n do
   begin
    for j:=1 to n do if i<>j then
      begin
       write(' Путь из вершины V',i,' в вершину V',j,': ');
       readln(a[i,j]);
      end else
        begin
          a[i,j]:=0;
          writeln(' Путь из вершину V',i,' в вершину V',j,': ',a[i,j]);
        end;
   end;
 for i :=1 to n do
 begin
 for j:=1 to n do write(a[i,j]:3);
 writeln;
 end;
   
   
   
 write('Введите вершину m: ');
  readln(m);
  p:=0;b[1,1]:=1;y:=1;x:=1;i:=1;j:=2;t:=0;
  while p<>1 do
   begin
    if (j<>n+1)and(i>0)and(i<n+1)and (a[i,j]=1)then 
     begin
       x:=x+1;
       y:=y+1;
       b[x,y]:=j;
       i:=j;
       j:=2;
       s:=x;
     end else
       begin
         if j<>n+1 then j:=j+1;
       end;
    if (j=n+1)and(i<>1) then 
      begin
       if (t<>0)and(s<>x) then j:=b[t,y]+1 else j:=b[x,y]+1; 
        y:=y-1;t:=x;
        while b[t,y]=0 do if b[t,y]=0 then t:=t-1;
        i:=b[t,y];
        s:=s+1;
      end; 
     if (j=n+1)and(i=1)then p:=1; 
   end;
 j:=1;
 for i:=1 to x do
  begin
  while b[i,j]=0 do
   begin
     if b[i,j]=0 then b[i,j]:=b[i-1,j]; 
     j:=j+1;
   end;
   j:=1;
  end; 
 t:=0;
 write('Контуры проходящие через вершину V1 и вершину m(V',m,') - ');
 for i:=1 to n do if a[i,1]=1 then t:=1;
 if t=1 then writeln('существуют!') else writeln('НЕ существуют!!!');
 t:=0;
 write('Пути соединяемые вершину V1 и вершину m(V',m,') - ');
 for i:=1 to n do if (a[i,m] = 1)and(m<>1) then t:=1;
 if t=1 then writeln('существуют!') else writeln('НЕ существуют!!!');
 if t=1 then
  begin
   writeln('Все пути из вершины V1 в вершину V',m,'(m): ');
   writeln;
   j:=1;
   for i:=2 to x do
    begin
      while b[i,j]<>0 do j:=j+1;
      if b[i,j-1]=m then 
       begin
        for y:=1 to j-1 do write('V',b[i,y],' ');
        writeln;
       end; 
      j:=1;
    end;
  end;
  writeln;
 end.

Новые блоги и статьи Все статьи Все блоги /
SDL3 для Web (WebAssembly): Обработчик клика мыши в браузере ПК и касания экрана в браузере на мобильном устройстве 8Observer8 02.02.2026 Содержание блога Для начала пошагово создадим рабочий пример для подготовки к экспериментам в браузере ПК и в браузере мобильного устройства. Потом напишем обработчик клика мыши и обработчик. . .	Философия технологии iceja 01.02.2026 На мой взгляд у человека в технических проектах остается роль генерального директора. Все остальное нейронки делают уже лучше человека. Они не могут нести предпринимательские риски, не могут. . .	SDL3 для Web (WebAssembly): Вывод текста со шрифтом TTF с помощью SDL3_ttf 8Observer8 01.02.2026 Содержание блога В этой пошаговой инструкции создадим с нуля веб-приложение, которое выводит текст в окне браузера. Запустим на Android на локальном сервере. Загрузим Release на бесплатный. . .	SDL3 для Web (WebAssembly): Сборка C/C++ проекта из консоли 8Observer8 30.01.2026 Содержание блога Если вы откроете примеры для начинающих на официальном репозитории SDL3 в папке: examples, то вы увидите, что все примеры используют следующие четыре обязательные функции, а. . .
SDL3 для Web (WebAssembly): Установка Emscripten SDK (emsdk) и CMake для сборки C и C++ приложений в Wasm 8Observer8 30.01.2026 Содержание блога Для того чтобы скачать Emscripten SDK (emsdk) необходимо сначало скачать и уставить Git: Install for Windows. Следуйте стандартной процедуре установки Git через установщик. . . .	SDL3 для Android: Подключение Box2D v3, физика и отрисовка коллайдеров 8Observer8 29.01.2026 Содержание блога Box2D - это библиотека для 2D физики для анимаций и игр. С её помощью можно определять были ли коллизии между конкретными объектами. Версия v3 была полностью переписана на Си, в. . .	Инструменты COM: Сохранение данный из VARIANT в файл и загрузка из файла в VARIANT bedvit 28.01.2026 Сохранение базовых типов COM и массивов (одномерных или двухмерных) любой вложенности (деревья) в файл, с возможностью выбора алгоритмов сжатия и шифрования. Часть библиотеки BedvitCOM Использованы. . .	SDL3 для Android: Загрузка PNG с альфа-каналом с помощью SDL_LoadPNG (без SDL3_image) 8Observer8 28.01.2026 Содержание блога SDL3 имеет собственные средства для загрузки и отображения PNG-файлов с альфа-каналом и базовой работы с ними. В этой инструкции используется функция SDL_LoadPNG(), которая. . .