Новичок
Профиль
Группа: Участник
Сообщений: 12
Регистрация: 21.4.2011
Репутация: нет
Всего: нет
|
Ребят, помогите пожалуйста решить задачу! Найти наибольший цикл во взвешенном графе, проходящий через обязательные вершины C и D и не проходящий через вершину A. вот что у меня получилось | Код |
Const NMAX = 9; { Максимальное количество вершин графа }
Type TMatr = Array[1..NMAX, 1..NMAX] of Integer; { тип матрицы смежности }
TVek = Array[1..NMAX] of Integer; { тип массива для стека St и массива M
для отметок о прохождении вершин }
Const A: TMatr = ( (0,1,0,1,0,0,0,1,0),
(1,0,1,0,0,1,0,0,0),
(0,1,0,1,1,0,1,0,0),
(1,0,1,0,0,0,1,0,0),
(0,0,1,0,0,0,0,1,1),
(0,1,0,0,0,0,0,0,0),
(0,0,1,1,0,0,0,0,0),
(1,0,0,0,1,0,0,0,0),
(0,0,0,0,1,0,0,0,0) ); { матрица смежности }
procedure TForm1.Button1Click(Sender: TObject);
Var Vn: Integer; { начальная вершина пути }
Vk: Integer; { конечная вершина пути }
C : Integer; { обязательная вершина }
D: Integer; {обязательная вершина}
N: Integer; {количество вершин в графе}
B: Integer; {вершина, которую цикл не должен содержать}
StMax:TVek;
KsStMax:Integer;
I: Integer; { параметр цикла }
Procedure AllP( A : TMatr; { матрица смежности }
N : Integer; { количество вершин графа }
Vn: Integer; { начальная вершина пути }
Vk: Integer; { конечная вершина пути }
C : Integer; { обязательная вершина }
D: Integer; {обязательная вершина}
B: Integer; {вершина, которую цикл не должен содержать}
Var StMax: TVek;{стек, содержащий наибольший цикл}
Var KsStMax: Integer {количество элементов в стеке}
);
Var St: TVek; { Стек }
I : Integer; { параметр цикла }
J : Integer; { параметр цикла }
Ks: Integer; { указатель верхушки стека }
V : Integer; { текущая вершина }
M : TVek; { массив для отметок о прохождении вершин }
Begin
For J := 1 To N Do { обнуление массива о прохождении вершин }
M[J] := 0;
Ks := 1; { указатель верхушки стека }
St[Ks] := Vn; { занесение в стек начальной вершины }
M[Vn] := N + 1; { отмечаем посещение вершины Vn }
M[Vk] := N + 1; { отмечаем посещение вершины Vk,
чтобы она не включалась в путь как промежуточная }
J :=0;
Repeat
V := St[Ks]; { номер текущей вершины V берём из стека }
Repeat { цикл поиска смежной вершины J }
J := J + 1;
If ((A[V,J] = 1) And (J = Vk)) { нашли конечную вершину Vk }
Then
Begin
I := 1; { проверка обязательной вершины C, D }
While ((St[I] <> C) And (St[I] <> D) And (St[I] = B) And (I <= Ks)) Do { в найденном пути (в стеке) }
I := I + 1;
If ((I = Ks) And ((V = C) And (Vn = D) Or (V = D) And (Vn = C)) And (Ks>KsStMax))
Then { найден очередной путь }
Begin
For I := 1 To Ks Do { вывод пути (содержимого стека) }
StMax[I]:=St[I];
KsStMax:=Ks;
End;
End;
Until ((J > N) Or
(A[V,J] = 1) And
(M[J] = 0));
If J > N
Then { шаг назад, ексли V-ая вершина исчерпана, из неё некуда пойти }
Begin { убираем из стека текущую вершину V }
J := V; { чтобы искать смежную вершину, начиная с вершины V+1 }
M[V] := 0; { чтобы использовать эту вершину в другом пути }
Ks := Ks - 1; { перемещаем указатель стека вниз }
End
Else { шаг вперёд, если подходящая смежная вершина найдена }
Begin
Ks := Ks + 1; { величиваем указатель стека }
St[Ks] := J; { заносим в стек найденную вершину J }
M[J] := V; { отмечаем посещение вершины J и запоминаем "отца" (предка) }
J := 0; { чтобы начать поиск смежной вершины с 1-ой }
End;
Until Ks = 0; { рассмотрены все варианты путей }
End;
begin
Vn := StrToInt(EditVn.Text);
Vk := StrToInt(EditVk.Text);
C := StrToInt(EditC.Text);
D :=StrToInt(EditD.Text);
B :=StrToInt(EditB.Text);
AllP(A, NMAX, Vn, Vk, C, D, B, StMax, KsStMax); { находим все варианты путей из Vn в Vk через C и D }
If (KsStMax=N+1)
Then
Begin
EditR.Text := 'Нет ни одного такого цикла';
For I := 1 To NMAX Do { очищаем от старых решений }
StringGrid1.Cells[I - 1,0] := '';
End
Else
Begin
EditR.Text := '';
For I:=1 To KsStMax Do
StringGrid1.Cells[I-1,0]:=IntToStr(StMax[I]);
StringGrid1.Cells[KsStMax,0]:=IntToStr(Vn);
End;
end;
end.
|
вот только она не работает((( M
MetalFan | Для правильной вставки кода программ есть кнопка "код" |
Это сообщение отредактировал(а) MetalFan - 23.5.2011, 18:02 |
Графы, Поиск в глубину 
Загрузка ...
