Задача

Считай путем
ONTHEWAY

Условие Комментарии Решение Тестовые файлы Оглавление

Описание
Задан ориентированный граф с N вершинами, пронумерованными целыми числами от 1 до N

Задание
Напишите программу, которая подсчитывает количество различных путей между всеми парами вершин графа

Входные данные
Входной файл содержит количество вершин графа N (1≤N≤33) и список дуг графа, заданных номерами начальной и конечной вершин

Выходные данные
Вывести в выходной файл матрицу N×N, элемент (i,j) которой равен числу различных путей, ведущих из вершины i в вершину j, или "-1", если существует бесконечно много таких путей

Например:

ONTHEWAY.IN
5
1 2
2 4
3 4
4 1
5 3
1 1

ONTHEWAY.OUT
-1 -1 0 -1 0
-1 -1 0 -1 0
-1 -1 0 -1 0
-1 -1 0 -1 0
-1 -1 1 -1 0

Идеи
Вычисление степеней матрицы смежности.

Комментарии
Пусть А=[a_ij] - матрица смежности графа, т.е. a_ij равно 1, если граф содержит дугу из вершины i в вершину j, и 0 в противном случае. Матрица А задает количество путей из одного ребра между всеми парами вершин графа

Аналогичным образом, элементы а_ij^k матрицы А^k определяют количество путей из k ребер [Шень95, п.9.1; Кристофидес 78, п.1.8]. Следовательно, матрица В=A+A²+...+A^N^-1 для каждой пары вершин (i,j) определяет суммарное количество путей из i в j, состоящих не более чем из N-1 ребра

Для каждой пары вершин (i,j) заданного графа мы имеем одну из следующих двух возможностей:

существует лишь конечное число путей из i в j (это означает, что часть графа между вершинами i и j (под этим термином мы подразумеваем подграф, образованный теми вершинами, в которых можно оказаться, и теми ребрами, по которым можно пройти, двигаясь из вершины i в вершину j) не содержит циклов). В этом случае длины этих путей ограничены N-1 ребром и а_ij^N=а_ij^N⁺¹=...=0
существует бесконечное число таких путей, т.е. соответствующая часть графа содержит цикл, а значит, и элементарный цикл. Поскольку количество ребер в этом цикле не превосходит N, то найдется и путь из i в j длины от N до 2N-1 ребер. В этом случае имеем а_ij^N + а_ij^N⁺¹+ ...+а_ij^2N-1>0. Заметим, что может случиться так, что а_ij^N=а_ij^N⁺¹=...=а_ij^2N-2=0, а а_ij^2N-1>0 . Рассмотрите, например, в цикле из N вершин пару соседних

Таким образом, ненулевые позиции матрицы (I+B)A^N=A^N+A^N+1+...+A^2N-1 соответствуют тем парам вершин, число путей между которыми бесконечно. В эти позиции результирующей матрицы необходимо занести значения "-1". В остальные позиции следует перенести числа из матрицы В

Следует отметить, что для выполнения описанных вычислений нужно использовать переменные типа Double или Extended. Максимальное число, которое может появиться в результирующей матрице, равняется 2³¹=MaxLongInt+1

Упражнения

Докажите последнее утверждение и постройте соответствующий пример
Придумайте, как вычислить В, используя лишь O(log N) операций над матрицами

Решение

{$A+,B-,D+,E+,F-,G-,I-,L+,N+,O-,P-,Q+,R+,S+,T-,V+,X+,Y+}
{$M 65520,0,655360}

program ontheway;
const NMax=33;
type LongInt = Comp;
     setByte = set Of Byte;
     PKnot = ^TKnot;
     TKnot = record
               Next:PKnot;
               N:Byte;
             end;
     TGraph=Array[1..NMax] of PKnot;
var A,B:TGRaph;
    N:Integer;
    Res:Array[1..NMax,1..NMax] of longInt;
    Is:Array[1..NMax] of Boolean;

Procedure New(var q:PKnot);
Begin
System.New(q);
q^.Next:=Nil;
q^.N:=0;
End;

Procedure Add(Var A:TGraph;i,j:Integer);
Var q:PKnot;
Begin
new(q);
q^.Next:=A[i];
A[i]:=q;
q^.N:=j;
End;

Procedure Init;
Var i,j:Integer;
Begin
Assign(Input,'ontheway.in');
ReSet(Input);

Read(N);
For i:=1 to N do begin
    A[i]:=Nil;
    B[i]:=Nil;
End;
FillChar(Is,SizeOf(Is),false);

while not seekEof do begin
    read(i,j);
    Add(A,i,j);
    Add(B,j,i);
    if (i=j) then Is[i]:=true;
end;

Close(Input);
End;

Var F:Array[1..NMax] of Integer;
    Was:Array[1..NMax] of Boolean;
    Order:Array[1..NMax] of Integer;
    Cnt,cntComp:Integer;
    Cond:Array[1..NMax,0..NMax] of Integer;
    numKnots:Array[1..NMax] of Integer;

Procedure firstDeep(k:Integer);
var q:Pknot;
Begin
q:=A[k];
Was[k]:=True;
while q<>Nil do begin
    if not Was[q^.N] then
      firstDeep(q^.N);

    q:=q^.next;
end;

Inc(Cnt);
Order[N-Cnt+1]:=k;
End;

Procedure secondDeep(k:Integer);
Var q:PKnot;
Begin
q:=B[k];
Was[k]:=True;
inc(Cond[cntComp,0]); Cond[cntComp,Cond[cntComp,0]]:=k;
F[k]:=cntComp;
Inc(numKnots[cntComp]);

while q<>Nil do begin
    if not Was[q^.N] then
      secondDeep(q^.N);

    q:=q^.Next;
end;
End;

Procedure strongSearch;
Var i:Integer;
Begin
FillChar(F,SizeOf(F),0);
FillChar(Was,SizeOf(Was),False);
Cnt:=0;
for i:=1 to N do
    if not Was[i] then
      firstDeep(i);

FillChar(Was,SizeOf(Was),false);
FillChar(Cond,SizeOf(Cond), 0);
FillChar(numKnots, SizeOf(numKnots),0);
cntComp:=0;
for i:=1 to N do
    if not Was[Order[i]] then begin
      inc(cntComp);
      secondDeep(Order[i]);
    end;
End;

Var newGraph:Array[1..NMax,1..NMax] of Boolean;

Procedure GenNewGraph;
Var i,j:Integer;
    q:PKnot;
Begin
fillChar(newGraph, SizeOf(newGraph), false);
for i:=1 to cntComp do
    newGraph[i,i]:=True;

for i:=1 to cntComp do
    for j:=1 to Cond[i,0] do begin
      q:=A[Cond[i,j]];
      while q<>Nil do begin
        newGraph[i,F[q^.N]]:=true;
        q:=q^.Next;
      end;
    end;
End;

Var resNew:Array[1..NMax,1..NMax] of longInt;

Procedure calculateWays;
Var i,j,k:Integer;
Begin
for i:=1 to cntComp do
    for j:=1 to cntComp do
      if newGraph[i,j] then
        if ( (numKnots[i]>1) or Is[Cond[i,1]] ) or
           ( (numKnots[j]>1) or Is[Cond[j,1]] ) then
          resNew[i,j]:=-1
        else
          if (i<>j) then resNew[i,j]:=1
          else resNew[i,j]:=0
      else resNew[i,j]:=0;

for k:=1 to cntComp do
    for i:=1 to cntComp do
      for j:=1 to cntComp do
        if (resNew[i,j]=-1) or (resNew[i,k]=-1) and (resNew[k,j]<>0) or
           (resNew[k,j]=-1) and (resNew[i,k]<>0) then
          resNew[i,j]:=-1
        else
          resNew[i,j]:=resNew[i,j]+resNew[i,k]*resNew[k,j];
End;

Procedure calculateResults;
Var i,j,k,m:Integer;
Begin
FillChar(Res, sizeOf(Res), 0);

for i:=1 to cntComp do
    for j:=1 to cntComp do
      for k:=1 to Cond[i,0] do
        for m:=1 to Cond[j,0] do
          Res[Cond[i,k], Cond[j,m]]:=resNew[i,j];
End;

Procedure printResults;
Var i,j:Integer;
Begin
Assign(Output,'ontheway.out');
ReWrite(Output);

for i:=1 to N do begin
    for j:=1 to N do
      Write(Res[i,j]:0:0,' ');
    WriteLn;
end;

Close(Output);
End;

Begin
Init;
strongSearch;
genNewGraph;
calculateWays;
calculateResults;
printResults;
End.