Движение по лабиринту: Определить и вывести на экран кратчайшее расстояние

uses
  HeapTrc,
  LineInfo;

program Maze_Lee_3;
 
uses
  HeapTrc,
  LineInfo;
 
type
 
  TInfo = record
    X, Y, N: 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
    begin
      root.Last^.Next := p;
    end
    else
    begin
      root.First := p;
    end;
    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 QueuePushXYN(var root: TQueueRoot; x, y, n: integer);
  var
    info: TInfo;
  begin
    info.X := x;
    info.Y := y;
    info.N := n;
    QueuePush(root, info);
  end;
 
  procedure QueuePopXYN(var root: TQueueRoot; var x, y, n: integer);
  var
    info: TInfo;
  begin
    QueuePop(root, info);
    x := info.X;
    y := info.Y;
    n := info.N;
  end;
 
{
**************************************************************
Реализация алгоритма Ли (волнового алгоритма)
**************************************************************
}
const
  BLANK = 0;
  WALL  = 1;
type
  TMaze = array of array of integer;
 
  procedure LeeAlgorithm(m, n: integer; const Maze: TMaze; var D: TMaze;
    Xs, Ys, Xf, Yf: integer);
  var
    Queue: TQueueRoot;
    x, y, WaveNum: integer;
 
    procedure TestCell(x, y, WaveNum: integer);
    begin
      if (x >= 0) and (x < m) and (y >= 0) and (y < n) then
        if (Maze[x, y] = BLANK) and (D[x, y] = 0) then
        begin
          QueuePushXYN(Queue, x, y, WaveNum);
        end;
    end;
 
  begin
    for x := 0 to m - 1 do
      for y := 0 to n - 1 do
        D[x, y] := 0;
    if not ((Xs >= 0) and (Xs < m) and (Ys >= 0) and (Ys < n)) then
      exit;
    if Maze[Xs, Ys] = WALL then
      exit;
    QueueInit(Queue);
    QueuePushXYN(Queue, Xs, Ys, 1);
    while not QueueIsEmpty(Queue) do
    begin
      QueuePopXYN(Queue, x, y, WaveNum);
      if (Maze[x, y] = BLANK) and (D[x, y] = 0) then
      begin
        D[x, y] := WaveNum;
        if (x = Xf - 1) and (y = Yf - 1) then
          break;
        TestCell(x - 1, y, WaveNum + 1);
        TestCell(x + 1, y, WaveNum + 1);
        TestCell(x, y - 1, WaveNum + 1);
        TestCell(x, y + 1, WaveNum + 1);
      end;
    end;
    QueueFree(Queue);
  end;
 
  procedure ShowPath(m, n: integer; const D: TMaze; Xs, Ys, Xf, Yf: integer);
  var
    Px, Py: array of integer;
    Distance, x, y, i: integer;
 
    procedure TestCell(xx, yy: integer);
    begin
      if (xx >= 0) and (xx < m) and (yy >= 0) and (yy < n) then
        if D[xx, yy] = Distance then
        begin
          x := xx;
          y := yy;
        end;
    end;
 
  begin
    if not ((Xf >= 0) and (Xf < m) and (Yf >= 0) and (Yf < n)) then
    begin
      writeln('There is not exist a path from (', Xs, ', ', Ys, ') to (', Xf,
        ', ', Yf, ').');
      exit;
    end;
    Distance := D[Xf, Yf];
    if Distance = 0 then
    begin
      writeln('There is not exist a path from (', Xs, ', ', Ys, ') to (', Xf,
        ', ', Yf, ').');
      exit;
    end;
    SetLength(Px, Distance);
    SetLength(Py, Distance);
    x := Xf;
    y := Yf;
    repeat
      Dec(Distance);
      Px[Distance] := x;
      Py[Distance] := y;
      if Distance = 0 then
        break;
      TestCell(x - 1, y);
      TestCell(x + 1, y);
      TestCell(x, y - 1);
      TestCell(x, y + 1);
    until False;
    Distance := D[Xf, Yf];
    writeln('There is exist a path from (', Xs, ', ', Ys, ') to (', Xf, ', ', Yf, ').');
    for i := 0 to Distance - 1 do
      writeln(succ(i): 2, '. (', Px[i], ', ', Py[i], ')');
  end;
 
{
**************************************************************
Чтение из файла лабиринта, начальной и конечной точек
**************************************************************
}
const
  BLANK_CHAR = '0';
  WALL_CHAR  = '1';
 
  procedure MazeLoadFromFile(var a: TMaze; var m, n, Xs, Ys, Xf, Yf: integer;
    sFileName: string);
  var
    x, y: integer;
    s: string;
    f: TextFile;
  begin
    m := 0;
    n := 0;
    Assign(f, sFileName);
    Reset(f);
    readln(f, m, n);
    SetLength(a, m, n);
    for x := 0 to m - 1 do
    begin
      readln(f, s);
      for y := 0 to n - 1 do
      begin
        if s[y + 1] = BLANK_CHAR then
          a[x, y] := BLANK
        else
          a[x, y] := WALL;
      end;
    end;
    readln(f, Xs, Ys);
    readln(f, Xf, Yf);
    Close(f);
  end;
 
var
  m, n: integer;
  Maze: TMaze;
  Xs, Ys, Xf, Yf: integer; {начальная и конечная клетки лабиринта}
  D: TMaze; {матрица расстояний от (Xs,Ys)}
begin
  MazeLoadFromFile(Maze, m, n, Xs, Ys, Xf, Yf, 'Maze01.txt');
  if m = 0 then
    exit;
  SetLength(D, m, n);
  LeeAlgorithm(m, n, Maze, D, Xs, Ys, Xf, Yf);
  ShowPath(m, n, D, Xs, Ys, Xf, Yf);
end.

    while not QueueIsEmpty(Stack) do
    begin
      QueuePopXY(Stack, x, y);
      Inc(i);
      //      writeln(i: 2, '. (', x, ', ', y, ')');
      Write(' (', x, ', ', y, ')');
      if (x <> Xf) or (y <> Yf) then
        Write(' ->');
      if i mod 5 = 0 then
        writeln;
    end;
    writeln;

  основная программа
  if (в файл) then   {если нужно отправить в файл - то перенаправляем вывод в файл}
  begin
    Assign(output, 'ShowPath.txt'); {<--- или другое имя}
    Rewrite(output);
  end
  else
    ClrScr;             {если не требуется вывод в файл - очищаем экран}
  ShowPath(...);    {процудура вывода пути}
  if (в файл) then  {восстанавливаем вывод на экран}
  begin
    Close(output);
    AssignCRT(output); {<--- это если подключать модуль CRT}
      или
    Assign(output, '');   {<--- это если НЕ подключать модуль CRT}
    Rewrite(output);
  end;