Кратчайший путь короля на шахматной доске

Задача в данном случае (маленькая доска всего на 64 клетки) может быть решена без рекурсии следующим образом.

Program ShortestPath;
type
  TCoords = record
    X, Y: byte;
  end;

  TBoardArray = array [0 .. 63] of TCoords;

var
  Goal: TCoords;
  Current: TCoords;
  i, j: integer;
  ArrBlocked, PathResult: TBoardArray;
  BlockedCount: byte;
  Board: array [1 .. 8, 1 .. 8] of integer;

procedure CountTurnsToCells;
var
  Repetitions: byte;
  BestPossible: byte;
begin
  for Repetitions := 1 to 63 do
    for j := 1 to 8 do
      for i := 1 to 8 do
        if Board[i, j] <> -2 then
        begin
          BestPossible := 255;
          if (i < 8) and (Board[i + 1, j] >= 0) then
            BestPossible := Board[i + 1, j] + 1;
          if (j < 8) and (Board[i, j + 1] >= 0) and
            (BestPossible > Board[i, j + 1] + 1) then
            BestPossible := Board[i, j + 1] + 1;
          if (i > 1) and (Board[i - 1, j] >= 0) and
            (BestPossible > Board[i - 1, j] + 1) then
            BestPossible := Board[i - 1, j] + 1;
          if (j > 1) and (Board[i, j - 1] >= 0) and
            (BestPossible > Board[i, j - 1] + 1) then
            BestPossible := Board[i, j - 1] + 1;
          { diagonal }
          if (j > 1) and (i > 1) and (Board[i - 1, j - 1] >= 0) and
            (BestPossible > Board[i - 1, j - 1] + 1) then
            BestPossible := Board[i - 1, j - 1] + 1;
          if (j > 1) and (i < 8) and (Board[i + 1, j - 1] >= 0) and
            (BestPossible > Board[i + 1, j - 1] + 1) then
            BestPossible := Board[i + 1, j - 1] + 1;
          if (j < 8) and (i < 8) and (Board[i + 1, j + 1] >= 0) and
            (BestPossible > Board[i + 1, j + 1] + 1) then
            BestPossible := Board[i + 1, j + 1] + 1;
          if (j < 8) and (i > 1) and (Board[i - 1, j + 1] >= 0) and
            (BestPossible > Board[i - 1, j + 1] + 1) then
            BestPossible := Board[i - 1, j + 1] + 1;

          if (BestPossible < 255) and
            ((Board[i, j] = -1) or (Board[i, j] > BestPossible)) then
            Board[i, j] := BestPossible;
        end;
end;

function GetPath: TBoardArray;
var
  n, TurnsNeeded: byte;
  NextCoord: TCoords;

  function FindNext(CurrentCoord: TCoords): TCoords;
  begin
    result.X := 0;
    result.Y := 0;

    if (CurrentCoord.X > 1) and (Board[CurrentCoord.X - 1, CurrentCoord.Y] >= 0)
      and (Board[CurrentCoord.X - 1, CurrentCoord.Y] < Board[CurrentCoord.X,
      CurrentCoord.Y]) then
    begin
      result.X := CurrentCoord.X - 1;
      result.Y := CurrentCoord.Y;
      exit;
    end;

    if (CurrentCoord.Y > 1) and (Board[CurrentCoord.X, CurrentCoord.Y - 1] >= 0)
      and (Board[CurrentCoord.X, CurrentCoord.Y - 1] < Board[CurrentCoord.X,
      CurrentCoord.Y]) then
    begin
      result.X := CurrentCoord.X;
      result.Y := CurrentCoord.Y - 1;
      exit;
    end;

    if (CurrentCoord.X < 8) and (Board[CurrentCoord.X + 1, CurrentCoord.Y] >= 0)
      and (Board[CurrentCoord.X + 1, CurrentCoord.Y] < Board[CurrentCoord.X,
      CurrentCoord.Y]) then
    begin
      result.X := CurrentCoord.X + 1;
      result.Y := CurrentCoord.Y;
      exit;
    end;

    if (CurrentCoord.Y < 8) and (Board[CurrentCoord.X, CurrentCoord.Y + 1] >= 0)
      and (Board[CurrentCoord.X, CurrentCoord.Y + 1] < Board[CurrentCoord.X,
      CurrentCoord.Y]) then
    begin
      result.X := CurrentCoord.X;
      result.Y := CurrentCoord.Y + 1;
      exit;
    end;
    { diagonal }
    if (CurrentCoord.X > 1) and (CurrentCoord.Y > 1) and
      (Board[CurrentCoord.X - 1, CurrentCoord.Y-1] >= 0) and
      (Board[CurrentCoord.X - 1, CurrentCoord.Y-1] < Board[CurrentCoord.X,
      CurrentCoord.Y]) then
    begin
      result.X := CurrentCoord.X - 1;
      result.Y := CurrentCoord.Y - 1;
      exit;
    end;

    if (CurrentCoord.X < 8) and (CurrentCoord.Y > 1) and
      (Board[CurrentCoord.X + 1, CurrentCoord.Y-1] >= 0) and
      (Board[CurrentCoord.X + 1, CurrentCoord.Y-1] < Board[CurrentCoord.X,
      CurrentCoord.Y]) then
    begin
      result.X := CurrentCoord.X + 1;
      result.Y := CurrentCoord.Y - 1;
      exit;
    end;

    if (CurrentCoord.X < 8) and (CurrentCoord.Y < 8) and
      (Board[CurrentCoord.X + 1, CurrentCoord.Y+1] >= 0) and
      (Board[CurrentCoord.X + 1, CurrentCoord.Y+1] < Board[CurrentCoord.X,
      CurrentCoord.Y]) then
    begin
      result.X := CurrentCoord.X + 1;
      result.Y := CurrentCoord.Y + 1;
      exit;
    end;

    if (CurrentCoord.X > 1) and (CurrentCoord.Y < 8) and
      (Board[CurrentCoord.X - 1, CurrentCoord.Y+1] >= 0) and
      (Board[CurrentCoord.X - 1, CurrentCoord.Y+1] < Board[CurrentCoord.X,
      CurrentCoord.Y]) then
    begin
      result.X := CurrentCoord.X - 1;
      result.Y := CurrentCoord.Y + 1;
      exit;
    end;

  end;

begin
  TurnsNeeded := Board[Goal.X, Goal.Y];
  NextCoord := Goal;
  for n := TurnsNeeded downto 1 do
  begin
    result[n] := NextCoord;
    NextCoord := FindNext(NextCoord);
  end;
  result[0] := NextCoord; // starting position
end;

procedure BoardOutput;
begin
  for j := 1 to 8 do
    for i := 1 to 8 do
      if i = 8 then
        writeln(Board[i, j]:2)
      else
        write(Board[i, j]:2);
end;

procedure OutputTurns;
begin
  writeln(' X Y');
  for i := 0 to Board[Goal.X, Goal.Y] do
    writeln(PathResult[i].X:2, PathResult[i].Y:2)
end;

begin
  { test values }
  Current.X := 2;
  Current.Y := 5;
  Goal.X := 8;
  Goal.Y := 7;
  ArrBlocked[0].X := 4;
  ArrBlocked[0].Y := 3;
  ArrBlocked[1].X := 2;
  ArrBlocked[1].Y := 2;
  ArrBlocked[2].X := 8;
  ArrBlocked[2].Y := 5;
  ArrBlocked[3].X := 7;
  ArrBlocked[3].Y := 6;
  BlockedCount := 4;

  { preparing the board }
  for j := 1 to 8 do
    for i := 1 to 8 do
      Board[i, j] := -1;

  for i := 0 to BlockedCount - 1 do
    Board[ArrBlocked[i].X, ArrBlocked[i].Y] := -2; // the blocked cells

  Board[Current.X, Current.Y] := 0; // set the starting position

  CountTurnsToCells;
  BoardOutput;

  if Board[Goal.X, Goal.Y] < 0 then
    writeln('no path') { there is no path }

  else
  begin
    PathResult := GetPath;
    writeln;
    OutputTurns
  end;

  readln;

end.

Идея следующая. Мы используем массив, представляющий доску. Каждая ячейка может быть установлена ​​либо в 0 - начальная точка, либо в -1 - неизвестная/недоступная ячейка, либо в -2 - заблокированная ячейка. Все положительные числа представляют собой минимальное количество оборотов для достижения текущей ячейки от начальной точки.

Позже мы проверяем, содержит ли ячейка цели число больше 0. Это означает, что король может двигаться в ячейку назначения. Если это так, мы находим ячейки с порядковыми номерами, следующие друг за другом от цели к начальной точке, и представляем их в массиве решений.

Две дополнительные процедуры: BoardOutput и OutputTurns выводят структуру Board и решение на консоль.

Поскольку размеры вашей проблемы настолько малы, вы не обязаны использовать самый эффективный метод. Таким образом, вы можете использовать BFS для поиска кратчайшего пути, потому что, во-первых, стоимость перемещения постоянна, во-вторых, вы не столкнетесь с ограничением памяти из-за небольшого размера проблемы.

 1 Breadth-First-Search(Graph, root):
 2 
 3     for each node n in Graph:            
 4         n.distance = INFINITY        
 5         n.parent = NIL
 6 
 7     create empty queue Q      
 8 
 9     root.distance = 0
10     Q.enqueue(root)                      
11 
12     while Q is not empty:        
13     
14         current = Q.dequeue()
15     
16         for each node n that is adjacent to current:
17             if n.distance == INFINITY:
18                 n.distance = current.distance + 1
19                 n.parent = current
20                 Q.enqueue(n)

https://en.wikipedia.org/wiki/Breadth-first_search

Но когда проблема становится больше, вы обязаны использовать более эффективные методы. Окончательное решение — использовать IDA*. Поскольку сложность пространства IDA* является линейной, и она всегда будет возвращать оптимальное решение, если вы используете последовательную эвристику.

A* Search — хороший алгоритм поиска пути для графов вроде шахматной доски. погуглив нашел реализация на C, которую можно адаптировать к Pascal.

A* сначала исследует наиболее перспективные пути, используя допустимую эвристику, чтобы определить, какие пути (вероятно, ) лучший, т. е. поиск сначала исследует самый прямой путь к цели и только исследует более окольные пути, если прямые пути заблокированы. В вашем случае вы можете либо использовать декартово расстояние в качестве эвристики, либо использовать расстояние Чебышева Расстояние до шахматной доски.

Вы можете преобразовать эту задачу в теорию графов, а затем применить один из стандартных алгоритмов.

Вы рассматриваете все поля узлов шахматной доски в графе. Все поля y, на которые король может переместиться с заданного поля x, связаны с x. Итак, c4 соединен с b3, b4, b5, c3, c5, d3, d4, d5. Удалите все узлы и их соединения, которые заблокированы.

Теперь найти кратчайший путь можно с помощью алгоритма Дейкстраса.

По сути, это то, что @asd-tm реализует в своем решении, но я думаю, что реализация алгоритма Дейкстры для общего случая и его использование для особого случая могут привести к более чистому и понятному коду. Отсюда отдельный ответ.