FAQ по графам

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;

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.

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.

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.

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;

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;

procedure F (a: Matrix);

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;

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;

const INF = 100000000;

 (D[j] > D[v] + A[v, j])