Форум программистов, компьютерный форум, киберфорум
Наши страницы

Pascal (Паскаль)

Войти
Регистрация
Восстановить пароль
 
 
Рейтинг: Рейтинг темы: голосов - 357, средняя оценка - 4.71
yanyk1n
4330 / 1461 / 152
Регистрация: 12.03.2009
Сообщений: 5,310
#1

FAQ по графам - Pascal

08.04.2010, 19:30. Просмотров 52605. Ответов 27

Лучший ответ Сообщение было отмечено автором темы, экспертом или модератором как ответ
Иногда на форуме появляются просьбы решить задачу на теорию графов. На теории такие задачи решаются не так уж и сложно, ведь сколько существует различных теорем, гипотез и так далее. Но когда дело доходит до программной реализации - возникают трудности. Поскольку теория графов является не только одной из сложных тем в высшей математике, но ещё сложнее реализовать какой-нибудь алгоритм на языке программирования. Также это излюбленная тема в олимпиадном программировании, поэтому данный материал также будет полезен не только для учащихся технических ВУЗов, но и для участников всевозможных олимпиад по информатике (я сам таковым являюсь ). Поэтому я решил создать мини-FAQ по графам, куда буду выкладывть основные алгоритмы и программы в данной теме,а по мере возможности тема будет расширяться новым материалом.

Если у вас есть предложения по развитию этого FAQ или у вас есть подходящие материалы, то пишите мне в ЛС. Рассмотрю всё

Итак, начнём.

1) ПЕРЕД ТЕМ, КАК ЧИТАТЬ ДАЛЬШЕ

Для решения задач следует понимать, что представляет из себя граф.
http://ru.wikipedia.org/wiki/Граф_(математика)

2) СПОСОБ ХРАНЕНИЯ ГРАФОВ В ПАМЯТИ.

Чаще всего используют два способа хранения:
  • Матрица смежности.
Представляет из себя двумерный массив размером NxN, где N — количество вершин графа. В матрице A[i,j]=1 (или больше, если граф взвешенный, то есть каждое ребро имеет свой вес или стоимость), если существует ребро между вершинами I и J (в ориентированном графе — можно ли добраться из вершины I к вершине J, то есть ребро направленно в одну сторону), или A[i,j]=0 в противном случае. Очевидно, что для ориетнированного графа a[i,j]=a[j,i] (поскольку ориентированным графом называют частный случай неориентированного графа, у которого каждому ребру i->j есть противонаправленный j->i)
  • Список рёбер.
Представляет собой двухмерный массив размером Mx2, где M — количество рёбер графа. В Каждая строка описывает:
sp[i,1] — от какой вершины отходит ребро i
sp[i,2] — к какой вершине приходит ребро i;
Отдельно можно завести массив P(M), где P[i] будет хранить вес ребра i;

Pascal
1
2
3
4
5
6
const MaxN = 100; //максимальное количество вершин
INF = 1000000000; //"бесконечность", заданная наперёд величина, во много раз бОльшая максимальному весу рёбер.
 
type Matrix = array[1..MaxN, 1..MaxN] of longint; //тип матрицы смежности. M[i,j] > 0, если существует ребро, идущее от вершины i к j
Spisok = array[1..MaxN * MaxN, 2]of longint; //тип матрицы, содержащая список рёбер. Каждая строка описывает ребро. (ребро k соединяет вершины с номерами s[k,1] и s[k,2])
Ves = array[1..MaxN * MaxN]of longint; //тип матрицы, содержащее веса рёбер для списка
В зависимости от условий и контекста задач, необходимо вести какой-то определённый формат хранения. При этом стоит иметь в виду, что одни алгоритмы работают с матрицей смежности, а другие - со списком рёбер. Но структура графа такова, что не составляет труда преобразовать список в таблицу, и наоборот. Поэтому бывает удобно вести сразу две структуры, так как чаще всего в задачах вводятся именно рёбра, а матрицу смежности построить, исходя из данного списка. Как это реализовать, будет рассмотрено подробнее.
3)ВВОД И ВЫВОД

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

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
procedure Input_Table(var A : Matrix; N : longint); //процедура ввода матрицы смежности A(N, N)
var i, j : longint;
begin
    for i := 1 to N do
    begin
        for j := 1 to N do read(A[i, j]);
        readln;
    end;
end;
 
procedure Input_Spisok(var P : Spisok; var V : Ves; M : longint); //процедура ввода списка взвешенных рёбер P(M,2), M - кол-во рёбер.
var i : longint;
begin
    for i := 1 to M do readln(P[i, 1], P[i, 2], V[i]);
end;
4) ОСНОВНЫЕ АЛГОРИТМЫ
  • Поиск в ширину (BFS).
Суть алгоритма заключается в том, чтобы перебрать всех преемников начальной вершины (корневого узла), и дальше по цепочке. Такой алгоритм помогает получить компоненту связности, то есть схему, куда можно прийти из какой-то заданной вершины. Применяя этот алгоритм поочерёдно для всех вершин, можно найти кратчайшее расстояние, оптимальный путь между двумя вершинами и так далее, в зависимости от предложенных условий.
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
procedure BFS(A : Matrix; N, V : integer); //обход в ширину (V - корневая вершина)
var i, ps, pe : integer;
visited : array [1..MaxN] of boolean; //массив посещённости вершин
q : array [1..MaxN] of integer; //"очередь" вершин
begin //в качестве списка очередных вершин будем использовать структуру "очередь"
    ps := 1; //начало очереди
    pe := 1; //конец очереди
    q[pe] := v; //в очередь помещается исходная вершина. На каждом шаге в очередь будем заносить всех преемников данной вершины (назовём их 1-го уровня, т.е. до которых можно дойти напрямую). Затем просматриваем в очереди занесённые ранее вершины 1-го уровня и добавляем в конец очереди вершины 2-го уровня и так далее до опустошения очереди.
    visited[v] := TRUE; //вершина V посещена
    while ps <= pe do //пока очередь не пуста
    begin
        for i := 1 to n do if (A[v, i] <> 0) and (not visited[i]) then //перебираем все связные с V вершины
        begin
            inc(pe); //и добавляем в очередь
            q[pe] := i; 
            visited[i] := true; //отмечаем вершину I пройденной
        end;
        inc(ps); //переходим к следующей вершине в очереди
        v := q[ps]; //и делаем её корневой
    end;
end;
  • Поиск в глубину (DFS)
Алгоритм поиска в глубину описывается следующим образом: для каждой непройденной вершины необходимо найти все непройденные смежные вершины и повторить поиск для них. Используется в качестве подпрограммы в алгоритмах поиска одно- и двусвязных компонент, топологической сортировки. Реализуется проще BFS, но затрат на ресурсов больше, так как здесь главную роль играет рекурсия

Pascal
1
2
3
4
5
6
7
8
9
procedure DFS(A : Matrix; N, V : integer); //обход в глубину (V - текущая вершина)
var i : integer;
begin
    visited[v] := TRUE; //вершина V посещена
    for i := 1 to N do if (A[v, i] <> 0) and (not visited[i]) then //если ребро между I и V существует и вершина I не была посещена ранее
    begin
        DFS(A, i); //проверяем вершину I
    end;
end;
  • Алгоритм Дейкстры
Находит кратчайшее расстояние от одной из вершин графа до всех остальных. Алгоритм работает только для графов без рёбер отрицательного веса (так как на таком цикле бесконечно будет уменьшатся наилучший путь). На каждом шаге цикла мы ищем вершину с минимальным расстоянием и флагом равным нулю. Затем мы отмечаем её пройденной и проверяем все соседние с ней вершины. Если в ней расстояние больше, чем сумма расстояния до текущей вершины и длины ребра, то уменьшаем его. Цикл завершается когда все вершины будут пройдены. Время работы алгоритма оценивается как O(N^2).

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
D : array[1..MaxN] of integer; //массив кратчайших расстояний
procedure Deisktr(A : Matrix; N, s : integer); //s - искомая вершина
var i, j, v, min : longint;
begin
    visited[s] := TRUE; //вершина S посещена
    for i := 1 to N do D[i] := A[s, i]; //изначальный массив расстояний
    for i := 1 to n-1 do //на каждом шаге находим минимальное решение и пытаемся его улучшить
    begin
        min := inf;
        for j := 1 to N do if (not visited[j]) and (D[j] < min) then
        begin
            min := D[j]; //минимальное расстояние
            v := j; //найденная вершина
        end;
        for j := 1 to N do if (D[j] > D[v] + A[v, j]) and (D[v] < inf) and (A[v, j] < inf) then D[j] := D[v] + A[v, j]; //пытаемся улучшить решение. Если в ней расстояние больше, чем сумма расстояния до текущей вершины и длины ребра, то уменьшаем его.
        s := v; //новая текущая вершина
        visited[v] := TRUE; //и она отмечается посещенной
    end;
end;
  • Алгоритм Флойда
Также находит массив кратчайших расстояний. Но в отличие от алгоритма Дейкстры, он использует динамическое программирование. На каждом шаге цикла k создаётся массив решений, где w[i,j] содержит минимальное расстояние, где используется используются только вершины 1,2..k и сами i и j. На начальном этапе W копирует матрицу смежности. Тогда на каждом k есть два варианта — минимальный путь идёт через вершину k или нет. Теоретически такой метод гораздо легче реализовать (банальный перебор), но использует больше машинных ресурсов, чем Дейкстра (сложность алгоритма оценивается как O(N^3), но зато ищет минимальные пути между всеми парами точек).

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
W : array[1..MaxN, 1..MaxN] of longint; //таблица кратчайших путей
 
function Min(a, b : longint) : longint;
begin
    if a < b then min := a else min := b;
end;
 
procedure floyd(A : Matrix; N : integer);
var i, j, k : integer;
begin
    for i := 1 to N do for j := 1 to N do W[i, j] := A[i, j]; //копируем матрицу смежности в таблицу расстояний
 
    for k := 1 to N do //перебираем все наборы вершин (1),(1,2),(1,2,3)...(1,2,3..N)
    for i := 1 to N do 
    for j := 1 to N do W[i,j] := min(W[i, j], W[i, k] + W[k, j]); //возможно два варианта: кратчайшее расстояние от i до j проходит через вершину k или нет.
end;
  • Алгоритм Краскала.
Находит каркас минимального веса, т.е такой подграф исходного графа, который бы был связным, содержал все вершины исходного графа и суммарный вес рёбер был наименьшим. В этой задаче используется список рёбер. Вначале текущее множество рёбер устанавливается пустым. Затем, пока это возможно, проводится следующая операция: из всех рёбер, добавление которых к уже имеющемуся множеству не вызовет появление в нём цикла (т.*е. зачем добавлять ребро R(i,j) в подграф, который содержит эти вершины, а значит, от одной можно добраться до другой), выбирается ребро минимального веса и добавляется к уже имеющемуся множеству. Когда таких рёбер больше нет, алгоритм завершён. Массив рёбер должен быть заранее отсортирован во весу (можно привести док-во: если сначала рассматривать ребро R1(i,j)>R2(i,j), то он потом будет удалён, так как мы встретили в списке рёбер R2(i,j), который весит меньше R1, а удаление рёбер в алгоритме не предусматривается).
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
procedure kraskal(V : Spisok; P : Ves; K, N : longint); //поиск подграфа наименьшего веса (метод Краскала). V(K) - данный список рёбер, P - их вес, N - количество вершин
type TSet = set of byte;
var i, j, k1, k2, b, count : integer;
mn : array[1..MaxN]of TSet; //массив множеств
select : array[1..MaxN * MaxN]of boolean; //выбрано ребро или нет
begin
    for i := k downto 1 do //сортировка рёбер по возрастанию веса
    for j:=1 to i-1 do if pp[j] > p[j + 1] then
    begin 
        b := P[j];
        P[j] := P[j+1];
        P[j+1] := b;
 
        b := V[j, 1];
        V[j, 1] := V[j+1, 1]; 
        V[j+1, 1] := b;
 
        b := V[j, 2];
        V[j, 2] := V[j+1, 2]; 
        V[j+1, 2] := b;
    end;  
    for i := 1 to N do mn[i] := [i]; //создаём N множеств - подграфов. Каждое содержит по одной вершине: [1],[2],[3],[4]...[N]
    count := N; //кол-во подграфов. Если удается найти требуемый подграф, то на выходе должен остаться 1 подграф 
    i := 1;
    while (count > 1) and (i <= k) do //пока есть нерассмотенные рёбра и кол-во подграфов больше одного
    begin
        for j := 1 to count do if V[i, 1] in mn[j] then k1 := j else if V[i, 2] in mn[j] then k2 := j; //перебираем все имеющиеся подграфы. В k1 и k2 запоминаем номера подграфов, куда входят вершины, которые соединяют ребро I.
        if k1 <> k2 then //если это два разных подграфа, т.е. текущее ребро соединяет их
        begin
            mn[k1] := mn[k1] + mn[k2]; //то соедияем подграфы!
            mn[k2] := []; 
            dec(count); //уменьшаем кол-во подграфов на единицу
            select[i] := TRUE; //текущее ребро отмечаем как использованное
        end;
        inc(i); //переходим к следующему ребру
    end;
    if count = 1 then //если после процедуры остался один подграф - выводим номера всех использованных рёбер, иначе - условий для существования единственного подграфа нет (хотя существуют задачи, где необходимо вычислить такие рёбра или вершины (смотря от контекста задачи), которые будут соединять найденные подграфы) 
    begin
        for i := 1 to k do if select[i] then write(i,' ');
        end else write('-1');
    end;
end;
5) ПРИМЕРЫ РЕШЕНИЯ ЗАДАЧ НА ГРАФЫ

1) Дано N городов, некоторые из них соединены двусторонними дорогами. Проезда по каждой дороге имеет свою стоимость. Необходимо составить программу, которая по заданной таблице истинности находит путь от города S1 до города S2, суммарная стоимость которая будет минимальна.
Формат входных данных: на вход подаётся файл, содержащий в первой строке N. S1 и S2. (1<=N<=50, 1<=S1<=N, 1<=S2<=N). Затем в следующих N строках идут числа, описывающие очередную строку матрицы смежности.
Формат выходных данных: на экран вывести города, которые следуют в искомом пути.
Пример:
Bash
1
2
3
4
5
6
5 2 4
0 7 0 8 12
7 0 1 0 0
0 1 0 4 2
8 0 4 0 1
12 0 2 1 0
Ответ:
Bash
1
2->3->5->4
Графическая иллюстрация решения примера:
FAQ по графам

Решение: наиболее удачным и быстродейственным способом нахождения пути от одного пункта к другому является метод Дейкстры, которая ищет минимальные расстояния от какой-то заданной точки до всех остальных. В алгоритме заведём массив предков P(N), который будет содержать минимальный путь, где P[I] - точка, от которой пришли в I по найденному минимальному пути. P[S] будет равно нулю, если S - корневая вершина (от которой и ищем пути).

Код программы:
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
const MaxN = 50;
INF = 1000000000; //"бесконечность"
 
type Matrix = array[1..MaxN,1..MaxN] of longint; //тип матрицы смежности. M[i,j] = true, если существует ребро, идущее от вершины i к j
 
var
A : Matrix; N, S1, S2: integer;
input: text;
 
procedure Input_Table(var A : Matrix; N : longint; var T : Text); //процедура ввода матрицы смежности A(N, N) из текстового файла T
var i, j : longint;
begin
    for i := 1 to N do
    begin
        for j := 1 to N do
        begin
            read(T, A[i, j]);
            if (a[i,j] = 0) and (i <> j) then a[i,j] := INF; //вершины, которые не связаны ребром, будем обзначать "бесконечностью" ввиду ограничения на вес рёбер
        end;
        readln(T);
    end;
end;
 
procedure Deikstr(s, s1 : integer); //s, s1 - искомые вершины (необходимо найти путь от s до s1)
var i, j, v, min, z : longint;
st, c : string;
visited : array[1..MaxN]of boolean; //массив посещённости вершин
D : array[1..MaxN] of longint; //массив кратчайших расстояний
P : array[1..MaxN] of integer; //массив предков, который поможет определить маршрут. p[i] будет содержать предпоследнюю вершину кратчайшего маршрута от s до i
 
begin
 
    for i := 1 to N do
    begin
        p[i] := s;
        visited[i] := FALSE;
    end;
    visited[s] := TRUE; //вершина S посещена
 
    for i := 1 to N do D[i] := A[s, i]; //изначальный массив расстояний
    D[s] := 0;
 
    p[s] := 0; //
 
    for i := 1 to N-1 do //на каждом шаге находим минимальное решение и пытаемся его улучшить
    begin
        min := INF;
        for j := 1 to N do if (not visited[j]) and (D[j] < min) then
        begin
            min := D[j]; //минимальное расстояние
            v := j; //найденная вершина
        end;
        for j := 1 to N do if (D[j] > D[v] + A[v, j]) and (D[v] < INF) and (A[v, j] < INF) then
        begin
            D[j] := D[v] + A[v, j]; //пытаемся улучшить решение. Если в ней расстояние больше, чем сумма расстояния до текущей вершины и длины ребра, то уменьшаем его.
            p[j] := v;
        end;
        s := v; //новая текущая вершина
        visited[v] := TRUE; //и она отмечается посещенной
    end;
 
    st := ''; //осталось преобразовать в формат вывода (мы проидёмся по всем вершинам кратчайшего пути от s до s1, но только в обратном порядке)
    z := p[s1]; //пока есть корневая вершина
    while z <> 0 do
    begin
        str(z,c); 
        st := c + '->' + st; //заносим в маршрут
        z := p[z]; //переходим к следующей вершине
    end;
    str(s1,c); //в маршрут записываем начальную вершину
    st := st + c;
    writeln(st);
end;
 
BEGIN
    assign(input,'input.txt');
    reset(input);
    readln(input, N, S1, S2);
    Input_Table(A, N, input);
    close(input);
    Deikstr(S1, S2);
END.
47
Надоела реклама? Зарегистрируйтесь и она исчезнет полностью.
Similar
Эксперт
41792 / 34177 / 6122
Регистрация: 12.04.2006
Сообщений: 57,940
08.04.2010, 19:30
Здравствуйте! Я подобрал для вас темы с ответами на вопрос FAQ по графам (Pascal):

Pascal FAQ - Pascal
Статьи и учебники Pascal Исходники Pascal

FAQ Прикладное - Pascal
Эта тема - &quot;дочка&quot; темы: http://www.cyberforum.ru/pascal/thread250560.html &gt; Форум программистов &gt; Форум Pascal (Паскаль) ...когда...

Ошибка в теме "ФАО по графам"? - Pascal
Добрый день. Пытаюст реализовать алгоритм &quot;Поиск в длину&quot;. Следуя по алгоритму, указанному в теме, код должен выглядеть так: const...

книги по графам - Turbo Pascal
Подскажите, какие учебники лучше всего подходят для изучения графов в турбо паскале?? в интернете я ничего хорошего не нашла, а учебники,...

Чем определяется одинаковость урлов /page?FAQ и /page.php?FAQ - PHP
Подскажите, пожалуйста, какая опция php или настройка сервера позволяет не указывать .php в урлах? Просто раньше у меня на сайте работал...

алгоритм по графам - Алгоритмы
Всем привет! Занимаюсь изучением динамического программирования при решении задач для графов. У меня 3 задачи: 1. Алгоритм...

27
Snoopy
1912 / 1069 / 90
Регистрация: 06.12.2008
Сообщений: 2,802
15.04.2010, 19:58 #2
Лучший ответ Сообщение было отмечено автором темы, экспертом или модератором как ответ
Поиск в глубину нерекурсивный методом.
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
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
uses crt;
{исходные данные}
var graph:array[1..100,1..100] of integer; {матрица смежности}
    n:integer; {кол-во вершин в графе}
    fin:text; {файл исходных данных}
{промежуточные}
    fout:text;
    nnew:array[1..100] of boolean; {массив признаков, просматривалась вершина или нет}
{результаты}
    st:array[1..100] of integer;
    fres:text; {результат работы}
 
procedure CheckGraph; {проверка матрицы смежности графа}
var i,j:integer;
begin
        for i:=1 to n do
        for j:=1 to n do
        begin
                if graph[i,j]>1 then 
                 graph[i,j]:=1; {если число больше единицы, то считаем что ребро есть}
                if graph[i,j]<0 then 
                 graph[i,j]:=0; {если число отрицательное, то считаем, что ребра нет}
                if ((i=j) and (graph[i,j]<>0)) then 
                 graph[i,j]:=0; {убираем петли из графа}
        end;
end;
 
procedure ShowGraph; {показать матрицу смежности графа}
var i,j:integer;
begin
        Clrscr;
        Writeln('The graph you inputed is:');
        for i:=1 to n do
        begin
                Writeln;
                Write(i,' | ');
                for j:=1 to n do
                Write (graph[i,j]:2,' '); {вывод матрицы}
        end;
        ReadKey;
end;
 
procedure Input; {ввод данных}
var ch:char; {выбор пользователя}
    cod:byte; {код ошибки при загрузке файла}
    fname:string; {название файла}
    i,j:integer;
begin
        repeat
        Clrscr;
        Writeln('Choose the source');
        Writeln('1. Keyboard');
        Writeln('2. File');
        Readln(ch);
        if ch='1' then {ассоциация с нажатием 1}
        begin
                Writeln('How many edges are in the graph?');
                Readln(n);
                while ((n<0) or (n>100)) do {неправильные входные данные}
                begin
                        if n<0 then 
                         Writeln('The number of edges must be positive. Try again');
                        if n>100 then 
                         Writeln('Top much edges! Try again');
                        Readln(n);
                end;
                for i:=1 to n do
                for j:=1 to n do
                begin
                        Writeln(i,'-',j,': '); 
                        Readln(graph[i,j]); {ввод элементов матрицы}
                end;
                CheckGraph; 
                ShowGraph;      
           end;
 
        if ch='2' then {ассоциация с нажатием 2}
        begin
                Writeln('The name of file is:'); 
                Readln(fname);
                Assign(fin, fname);
                {$I-}
                Reset(fin);
                {$I+}
                cod:=IOResult;
                while cod<>0 do
                begin
                        Writeln('I cannot find a file ',fname,'    Choose another file');
                        Readln(fname);
                        Assign(fin, fname);
                        {$I-}
                        Reset(fin);
                        {$I+}
                        cod:=IOResult;
                end;
                Readln(fin, n);
                for i:=1 to n do
                        for j:=1 to n do
                        Read(fin,graph[i,j]);
                CheckGraph;
                ShowGraph;
                close(fin);
        end;
        until ((ch='1') or (ch='2'));
end;
 
procedure ShowRes; {показать результаты}
var i:integer;
begin
        Assign(fres, 'results.txt');
        Rewrite(fres);
        for i:=1 to n do
        begin
        Writeln(fres,st[i]);
        Writeln(st[i]);
        end;
        close(fres);
end;
 
procedure WriteToLog(a:integer); {запись в лог}
var i:integer;
begin
Writeln(fout, 'Current edge: ',a);
for i:=1 to n do
        Write(fout, nnew[i]:5,' ');
Writeln(fout);
end;
 
procedure Pgn(v:integer); {процедура поиска в глубину}
var yk,t,j,k:integer;
    stt:array [1..100] of integer;
    pp:boolean; {можно идти дальше или нужно возвращаться}
begin
        Assign(fout, 'log.txt');
        Rewrite(fout);
        yk:=1; {указатель на стек}
        k:=1; {номер элемента массива}
        st[yk]:=v;
        stt[yk]:=v;
        nnew[v]:=false;
        while (yk<>0) do {пока стек не пуст}
        begin
                t:=stt[yk]; {выбор самой верхней вершины}
                j:=1;
                pp:=false;
                WriteToLog(t);
        repeat
        if ((graph[t,j]=1) and (nnew[j]=false)) then
                pp:=true
        else
                j:=j+1;
        until ((pp=true) or (j>n)); {найдена новая вершина или все вершины,связанные с данной вершиной, просмотрены}
        if (pp=true) then
        begin
                yk:=yk+1;
                nnew[t]:=true; {добавляем номер вершины}
                k:=k+1;
                st[k]:=j;
                stt[yk]:=j;
        end
        else {возврат}
        begin
                nnew[t]:=true;
                yk:=yk-1; {убираем номер вершины}
        end;
        end;
        close(fout);
end;
 
procedure DFS; {приглашение к поиску в глубину}
var v:integer;
begin
        Writeln;
        Writeln('Enter the number of edge, wherefrom to start depth search');
        Readln(v);
        while((v<0) or (v>n)) do {неправильные входные данные}
        begin
                Writeln('There is no such edge in the graph. Try again');
                Readln(v);
        end;
        Pgn(v);
end;
 
begin {main}
Input;
DFS;
ShowRes;
Readln;
end.
21
yanyk1n
4330 / 1461 / 152
Регистрация: 12.03.2009
Сообщений: 5,310
19.04.2010, 20:30  [ТС] #3
Лучший ответ Сообщение было отмечено автором темы, экспертом или модератором как ответ
2) В некотором городе Н-ске имеется свой метрополитен. Администрация города решила построить новую кольцевую линию. "Центром" этого кольца должна стать одна станций, при этом "радиус" такого кольца - минимальное кол-во станций, которое надо проехать, чтобы достичь кольцевой линии. То есть если радиус равен R - то кольцевая линия должна строиться на тех станциях, до которых можно добраться как минимум через R станций. Кольцо должно иметь как минимум две станции. Программа должна вывести все станции, через которые надо провести новую линию, или 0, если кольцо нельзя постоить.

Формат входных данных:
Первая строка содержит число N - количество станций метро (1<=N<=150) и число K. В следующих K строках содержится информация, описывающая схему. Сначала в строке идёт D - номер станции, затем число M, а далее - M чисел, которые показывают, с какими станциями соединена станция D.
В предпоследней строке - станция, которая будет "центром" станции, а в последней - радиус кольца.

Формат выходных данных:
На экран вывести номера искомых станций (в любом порядке). Если кольцо нельзя построить - вывести 0.

Пример:
Bash
1
2
3
4
5
6
7
8
9 5
3 3 1 4 6
2 2 1 4
7 2 1 9
5 3 1 8 6
4 2 8 9
1
1
Ответ:
Bash
1
2 3 5 7
Графическое представление примера:
FAQ по графам

Решение: при помощи поиска в ширину (BFS) на k-ой итерации цикла мы будем находить все станции, до которых можно добраться как минимум через k станций. Сделав ограничение по R и записывая "уровень" каждой станции, мы определим все такие станции.

Код программы:
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
const MaxN = 100;
type Matrix = array[1..MaxN,1..MaxN] of boolean; //тип матрицы смежности. M[i,j] = true, если станции i и j соединены.
 
var
A : Matrix;
i, j, N, k, aa, bb, S, R, c: integer;
 
procedure BFS(A : Matrix; N, V, R : integer); //обход в ширину (V - корневая вершина)
var i, ps, pe : integer;
visited : array [1..MaxN] of boolean; //массив посещённости вершин
q : array [1..MaxN] of integer; //"очередь" вершин
ql : array [1..MaxN] of integer; //и их уровней.
begin //в качестве списка очередных вершин будем использовать структуру "очередь"
    ps := 1; //начало очереди
    pe := 1; //конец очереди
    q[pe] := v; //в очередь помещается исходная вершина. На каждом шаге в очередь будем заносить всех преемников данной вершины (назовём их 1-го уровня, т.е. до которых можно дойти напрямую). Затем просматриваем в очереди занесённые ранее вершины 1-го уровня и добавляем в конец очереди вершины 2-го уровня и так далее до опустошения очереди.
    visited[v] := TRUE; //вершина V посещена
    ql[ps] := 0; //сама вершина - нулевой уровень
    while (ps <= pe) and (ql[ps] < R) do //пока очередь не пуста или не достигли необходимого уровня R
    begin
        for i := 1 to n do if (A[v, i]) and (not visited[i]) then //перебираем все связные с V вершины
        begin
            inc(pe); //и добавляем в очередь
            q[pe] := i;
            ql[pe] := ql[ps] + 1; //отмечаем новый уровень преемника.
            visited[i] := true; //отмечаем вершину I пройденной
        end;
 
        inc(ps); //переходим к следующей вершине в очереди
        v := q[ps]; //и делаем её корневой
    end;
    while (ql[ps] = R) and (ps <= pe) do //после работы цикла в очереди останутся только вершины, имеющие уровень R и более.
    begin
        write(q[ps],' ');
        inc(ps);
    end;
end;
 
BEGIN
    assign(input,'input.txt');
    reset(input);
    readln(input, N, c);
    for i:=1 to c do
    begin
        read(input, aa, k);
        for j:=1 to k do
        begin
            read(input, bb);
            A[aa, bb] := true;
            A[bb, aa] := true;
        end;
        readln(input);
    end;
    readln(input, S);
    readln(input, R);
    close(input);
    BFS(A, N, S, R);
END.
25
Dani
1393 / 637 / 57
Регистрация: 11.08.2011
Сообщений: 2,282
Записей в блоге: 2
Завершенные тесты: 1
06.12.2012, 17:29 #4
Лучший ответ Сообщение было отмечено автором темы, экспертом или модератором как ответ
1) рекурсия в процедуре DFS передается неправильно. 3 Варианта: либо сделать матрицу смежной глобальной, например, так:
Pascal
1
2
3
4
5
6
7
8
9
10
11
var a: Matrix;
 
procedure DFS(N, V : integer); //обход в глубину (V - текущая вершина)
var i : integer;
begin
    visited[v] := TRUE; //вершина V посещена
    for i := 1 to N do if (A[v, i] <> 0) and (not visited[i]) then //если ребро между I и V существует и вершина I не была посещена ранее
    begin
        DFS(n, i); //проверяем вершину I
    end;
end;
2 Вариант: Сделать 2 процедуры - одна во второй. В первую передавать массив, а вторая - пусть им пользуется. Если передавать массив в рекурсию - программа съест очень много памяти.

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
procedure DFS (A: Matrix; N: integer);
 
procedure DFS1(V : integer); //обход в глубину (V - текущая вершина)
var i : integer;
begin
    visited[v] := TRUE; //вершина V посещена
    for i := 1 to N do if (A[v, i] <> 0) and (not visited[i]) then //если ребро между I и V существует и вершина I не была посещена ранее
    begin
        DFS1(i); //проверяем вершину I
    end;
end;
 
begin
end;
3 вариант: если массив передается в процедуру без var
Pascal
1
procedure F (a: Matrix);
То, при изменении элементов в массиве А, который передается откуда-то изменений не произойдет, т.к. произошло копирование массива. Чтобы избежать повторного копирования, я бы сделал так:
Pascal
1
2
3
4
5
6
7
8
9
procedure DFS(var A : Matrix; N, V : integer); //обход в глубину (V - текущая вершина)
var i : integer;
begin
    visited[v] := TRUE; //вершина V посещена
    for i := 1 to N do if (A[v, i] <> 0) and (not visited[i]) then //если ребро между I и V существует и вершина I не была посещена ранее
    begin
        DFS(A, n, i); //проверяем вершину I
    end;
end;
(Хотя, я вообще не люблю передавать массивы в процедуры - мне кажется, что лучше сделать их глобальными, выиграть в памяти, во времени, однако нужно пользоваться таким массивом аккуратно.

2) Алгоритм Дейкстры можно ускорить. Если на текущем шаге вершину для посещения алгоритм не нашел, то полезнее будет завершить цикл, чем проверять каждый раз найдена ли вершина.

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
procedure Deisktr(A : Matrix; N, s : integer); //s - искомая вершина
var i, j, v, min : longint;
begin
    visited[s] := TRUE; //вершина S посещена
    for i := 1 to N do D[i] := A[s, i]; //изначальный массив расстояний
    for i := 1 to n-1 do //на каждом шаге находим минимальное решение и пытаемся его улучшить
    begin
        min := inf;
        for j := 1 to N do if (not visited[j]) and (D[j] < min) then
        begin
            min := D[j]; //минимальное расстояние
            v := j; //найденная вершина
        end;
 
        if D[v] = inf then
         break;
        for j := 1 to N do if (D[j] > D[v] + A[v, j]) and (A[v, j] < inf) then D[j] := D[v] + A[v, j]; //пытаемся улучшить решение. Если в ней расстояние больше, чем сумма расстояния до текущей вершины и длины ребра, то уменьшаем его.
        s := v; //новая текущая вершина
        visited[v] := TRUE; //и она отмечается посещенной
    end;
end;
4
yutr777
5 / 5 / 0
Регистрация: 07.04.2013
Сообщений: 85
12.04.2013, 18:27 #5
Подскажите, за что отвечает переменная inf в алгоритме Дейкстры?
0
Dani
1393 / 637 / 57
Регистрация: 11.08.2011
Сообщений: 2,282
Записей в блоге: 2
Завершенные тесты: 1
12.04.2013, 23:20 #6
yutr777, INF - это константа бесконечности, т.е. некоторое большое число, которое соответствует бесконечности в программе, например, 100000000.
Pascal
1
const INF = 100000000;
0
Bizyaga
0 / 0 / 0
Регистрация: 20.04.2013
Сообщений: 12
02.05.2013, 19:37 #7
подскажите пожалуйста, как сделать так, чтобы программа с графами выполняла задачу Эйлера (там где нужно пройтись по всем островам, побывав на каждом мосту по разу)
сделала возможность ставить графы в поле Image, а как дальше быть - не знаю
0
Pasacal-men
10 / 0 / 1
Регистрация: 27.11.2013
Сообщений: 8
27.11.2013, 21:30 #8
Цитата Сообщение от Dani Посмотреть сообщение
yutr777, INF - это константа бесконечности, т.е. некоторое большое число, которое соответствует бесконечности в программе, например, 100000000.
Pascal
1
const INF = 100000000;
INF:=maxlongint;
LOL?
0
Dani
1393 / 637 / 57
Регистрация: 11.08.2011
Сообщений: 2,282
Записей в блоге: 2
Завершенные тесты: 1
27.11.2013, 21:47 #9
Pasacal-men, нифига не LOL
Pascal
1
 (D[j] > D[v] + A[v, j])
А теперь подумай, почему это переполнится с MAXLONGINT
0
Pasacal-men
10 / 0 / 1
Регистрация: 27.11.2013
Сообщений: 8
05.12.2013, 22:35 #10
Я не про это. Если нужно использовать бесконечность для программы то maxlongint подходит в самый раз. Но если хочешь maxlongint div 2.
0
Dani
1393 / 637 / 57
Регистрация: 11.08.2011
Сообщений: 2,282
Записей в блоге: 2
Завершенные тесты: 1
06.12.2013, 16:54 #11
Pasacal-men, да подходит. Но зачем писать столько букв, если правильнее нажать клавишу 1 и зажать 0 ?
0
xbron
0 / 0 / 0
Регистрация: 25.04.2012
Сообщений: 29
08.12.2013, 16:12 #12
Добрый день! Огромное спасибо за информацию, есть одно "но",здесь описаны разные алгоритмы,а не могли бы вы написать алгоритм "Форда-Беллмана" для неориентированного графа с учетом отрицательных весов ? Заранее благодарен!
0
Кчхай
1 / 1 / 1
Регистрация: 29.10.2013
Сообщений: 69
20.12.2013, 20:37 #13
Объясни, будь добр, как хранить графы на списке смежных вершин? У меня в задачах кол-во ребер\вершин доходит до 200000, и ни матрица смежности, ни список ребер не подходят.
0
Algoritmer
155 / 95 / 13
Регистрация: 07.03.2013
Сообщений: 484
Записей в блоге: 1
21.10.2014, 20:20 #14
Цитата Сообщение от Bizyaga Посмотреть сообщение
чтобы программа с графами выполняла задачу Эйлера
Вот что удалось найти в Википедии.
procedure find_all_cycles (v)
var массив cycles
1. пока есть цикл, проходящий через v, находим его
добавляем все вершины найденного цикла в массив cycles (сохраняя порядок обхода)
удаляем цикл из графа
2. идем по элементам массива cycles
каждый элемент cycles[i] добавляем к ответу
из каждого элемента рекурсивно вызываем себя: find_all_cycles (cycles[i])
0
eugene4
12 / 4 / 0
Регистрация: 15.11.2015
Сообщений: 51
15.11.2015, 14:20 #15
yanyk1n,
Уважаемый форумчанин "yanyk1n", большое спасибо за страничку:
FAQ по графам
узнал много полезного! Поскольку программистом не являюсь - убедительная просьба: как можно подробнее расписать процесс решения популярной игры - головоломки "15" (Пятнашки) в упрощенном варианте с полем 3х3. Она ведь тоже попадает в раздел "алгоритмы на графах" и, видимо относится к алгоритмам рекурсивного "поиска в глубину"... Интересует буквально все: постановка задачи, представление исходных данных в программе, выбор наиболее подходящего алгоритма решения.

Заранее благодарю, Евгений
0
15.11.2015, 14:20
MoreAnswers
Эксперт
37091 / 29110 / 5898
Регистрация: 17.06.2006
Сообщений: 43,301
15.11.2015, 14:20
Привет! Вот еще темы с ответами:

Задачка по графам - C++
Здравствуйте уважаемые знатоки! Необходима помощь по графам. Написал прогу, но не могу откомпилировать. Сломал голову, пытаясь понять суть...

Книги по графам - C++
Подскажите пожалуйста, по какой книге лучше всего начать изучение графов в с++ с нуля? и если возможно, киньте ссылку

Задание по графам - Ruby
Проверить достижимость в графе одной вершины из другой. Граф задан списком ребер. Примеры: в графе ((1 2)(2 3)(3 4)(1 5)) вершина 4...

Задача по Графам - Дискретная математика
Столкнулся с задачей на графы... Вот условие: Составьте все возможные планы маршрута путешествия по историческим местам, если...


Искать еще темы с ответами

Или воспользуйтесь поиском по форуму:
15
Ответ Создать тему
Опции темы

КиберФорум - форум программистов, компьютерный форум, программирование
Powered by vBulletin® Version 3.8.9
Copyright ©2000 - 2017, vBulletin Solutions, Inc.
Рейтинг@Mail.ru