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

{
Нахождение длины кратчайшего пути от одной вершины-источника
ко всем остальным вершинам графа с применением метода поиска
в ширину. Используйте представление графа в виде матрицы смежности.
}
program BFS;
 
type
{
Тип, для идентификации вершины в очереди
}
  TInfo = record
    Vertex: integer;
  end;
{
**************************************************************
Реализация очереди на динамических списках
**************************************************************
}
  PQueueElement = ^TQueueElement;
 
  TQueueElement = record
    Info: TInfo;
    Next: PQueueElement;
  end;
 
  TQueueRoot = record
    First, Last: PQueueElement;
  end;
 
  procedure QueueInit(var root: TQueueRoot);
  begin
    root.First := nil;
    root.Last  := nil;
  end;
 
  procedure QueuePush(var root: TQueueRoot; info: TInfo);
  var
    p: PQueueElement;
  begin
    new(p);
    p^.Info := info;
    p^.Next := nil;
    if Assigned(root.Last) then
      root.Last^.Next := p
    else
      root.First := p;
    root.Last := p;
  end;
 
  procedure QueuePop(var root: TQueueRoot; var info: TInfo);
  var
    p: PQueueElement;
  begin
    if not Assigned(root.Last) then
    begin
      exit;
    end;
    info := root.First^.Info;
    p := root.First;
    if root.First <> root.Last then
    begin
      root.First := root.First^.Next;
    end
    else
    begin
      root.First := nil;
      root.Last  := nil;
    end;
    dispose(p);
  end;
 
  function QueueIsEmpty(root: TQueueRoot): boolean;
  begin
    QueueIsEmpty := (root.First = nil);
  end;
 
  procedure QueueFree(var root: TQueueRoot);
  var
    p, q: PQueueElement;
  begin
    p := root.First;
    while Assigned(p) do
    begin
      q := p;
      p := p^.Next;
      Dispose(q);
    end;
    QueueInit(root);
  end;
 
  procedure QueuePushV(var root: TQueueRoot; V: integer);
  var
    info: TInfo;
  begin
    info.Vertex := V;
    QueuePush(root, info);
  end;
 
  procedure QueuePopV(var root: TQueueRoot; var V: integer);
  var
    info: TInfo;
  begin
    QueuePop(root, info);
    V := info.Vertex;
  end;
 
{
**************************************************************
Реализация алгоритма обхода в ширину (BFS)
**************************************************************
}
const
  INFINITY = MaxInt;
type
  TAjacentMatrix = array of array of integer;
  TDistance = array of integer;
 
  procedure BFS_Enumerate(n: integer; const M: TAjacentMatrix;
    StartNode: integer; var D: TDistance);
  var
    Queue: TQueueRoot;
    WaveNum: integer;
    V, i:  integer;
  begin
    if n <= 0 then
      exit;
    {инициализация матрицы расстояний}
    for V := 0 to n - 1 do
      D[V] := INFINITY;
    if (StartNode < 0) or (StartNode >= n) then
      exit;
    QueueInit(Queue);
    QueuePushV(Queue, StartNode);
    D[StartNode] := 0;
    while not QueueIsEmpty(Queue) do
    begin
      QueuePopV(Queue, V);
      WaveNum := D[V];
      for i := 0 to n - 1 do
      begin
        if i = V then
          continue;
        if M[V, i] <> 0 then
        begin
          if D[i] = INFINITY then
          begin
            QueuePushV(Queue, i);
            D[i] := WaveNum + 1;
          end;
        end;
      end;
    end;
    QueueFree(Queue);
  end;
 
{
**************************************************************
Чтение из файла матрицы смежности и начальной вершины
**************************************************************
}
const
  NOLINK_CHAR = '0';
  LINK_CHAR = '1';
 
  procedure AdjacentMatrixLoadFromFile(var a: TAjacentMatrix;
  var n: integer; var StartNode: integer; sFileName: string);
  var
    x, y: integer;
    s: string;
    f: TextFile;
  begin
    n := 0;
    Assign(f, sFileName);
    Reset(f);
    readln(f, n);
    SetLength(a, n, n);
    for x := 0 to n - 1 do
    begin
      readln(f, s);
      for y := 0 to n - 1 do
      begin
        if s[y + 1] = NOLINK_CHAR then
          a[x, y] := 0
        else
          a[x, y] := 1;
      end;
    end;
    readln(f, StartNode);
    Close(f);
  end;
 
  procedure ShowAdjacentMatrix(n: integer; const M: TAjacentMatrix);
  var
    i, j: integer;
  begin
    for i := 0 to n - 1 do
    begin
      for j := 0 to n - 1 do
        Write(M[i, j]: 2);
      writeln;
    end;
  end;
 
  procedure ShowDistance(n: integer; const D: TDistance);
  var
    i: integer;
  begin
    for i := 0 to n - 1 do
      if D[i] = INFINITY then
        Write(' inf')
      else
        Write(D[i]: 4);
    writeln;
  end;
 
var
  n: integer;         {количество вершин}
  M: TAjacentMatrix;  {матрица смежности}
  StartNode: integer; {вершина, от которой будут искаться минимальные расстояния}
  D: TDistance;       {массив расстояний от StartNode}
begin
  AdjacentMatrixLoadFromFile(M, n, StartNode, 'Adjacent.txt');
  SetLength(D, n);
  BFS_Enumerate(n, M, StartNode, D);
  ShowAdjacentMatrix(n, M);
  ShowDistance(n, D);
end.