FAQ по графам - Pascal

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; //тип матрицы, содержащее веса рёбер для списка

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;

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;

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;

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;

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;

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 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

2->3->5->4

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.