Поиск путей в лабиринте

Доброго времени суток, уважаемое сообщество.

Предистория


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

Вот собственно и он:



Рабочий день был скучный, настроение было отличное. Цель, средства и желание имеются. Вывод очевиден, будем проходить.

История


Для удобного решения, необходимо имеющееся изображение лабиринта, привести к типу двумерного массива. Каждый элемент которого может принять одно из 3-ех значений:

const
  WALL=-1;
  BLANK=-2;
  DEADBLOCK=-3;


Наперед, хочу показать функции для сканирования изображения лабиринта с последующей записью данных в массив, и функцию генерации нового изображения, на основании данных из массива:
Сканирование изображения:

...
var
  N:integer=600;
  LABIRINT:array[0..600,0..600] of integer;
...
var bit:TBitmap;
    i,j:integer;
begin
bit:=TBitmap.Create;
If OpenDialog1.Execute then
  begin
  bit.LoadFromFile(OpenDialog1.FileName);
  for i:=0 to N do
    for j:=0 to N do
      if bit.Canvas.Pixels[j,i]=clWhite then
        LABIRINT[j,i]:=BLANK else LABIRINT[j,i]:=WALL;
  bit.Free;
...
  end;
end;
...


Генерация изображения:

...
var
  N:integer=600;
  LABIRINT:array[0..600,0..600] of integer;
...
procedure genBitmap;
var bit:TBitmap;
    i,j:Integer;
begin
bit:=TBitmap.Create;
bit.Width:=N+1;
bit.Height:=N+1;

for i:=0 to N do
  for j:=0 to N do
    begin
    if LABIRINT[i,j]=BLANK then bit.Canvas.Pixels[i,j]:=clWhite //
      else
        if LABIRINT[i,j]=WALL then bit.Canvas.Pixels[i,j]:=clBlack
          else bit.Canvas.Pixels[i,j]:=clRed;
    end;
  bit.SaveToFile('tmp.bmp');
  bit.Free;
end;
...



Для начала, необходимо пересохранить изображение, как монохромный bmp, для того, чтоб иметь 2 цвета белый или черный. Если присмотреться к лабиринту, то он имеет стенку толщиной в 2 пикселя, а проход толщиной в 4 пикселя. Идеально было бы сделать, чтоб толщина стенки и прохода была 1 пиксель. Для этого необходимо перестроить изображение, разделить изображение на 3, то есть удалить каждый 2рой и 3тий, ряд и столбик пикселей из рисунка (на правильность и проходимость лабиринта это не повлияет). Сказано сделано:

Подготовленный рисунок:

Ширина и высота изображения: 1802 пикселя.


1. Используем функцию сканирования изображения.
2. Перестраиваем изображение:

...
var
  N:integer=1801;
  LABIRINT:array[0..1801,0..1801] of integer;
...
procedure rebuildArr2;
var i,j:integer;
begin
for i:=0 to ((N div 3) ) do
  for j:=0 to ((N div 3) ) do
    LABIRINT[i,j]:=LABIRINT[i*3,j*3];
N:=N div 3;
end;
...


3. Генерируем перестроенное изображение.

Результат работы процедуры:


Ширина и высота изображения: 601 пиксель.



Итак, у нас есть изображение лабиринта нужного вида, теперь самое интересное, поиск всех вариантов прохождения лабиринта. Что у нас есть? Массив с записанными значениями WALL — стена и BLANK — проход.

Была одна неудачная попытка найти прохождение лабиринта с помощью волнового алгоритма. Почему неудачная, почти во всех ситуациях данный алгоритм приводил к ошибке «Stack Overflow». Я уверен на 100%, что используя его, можно найти прохождение лабиринта, но появился запал придумать что-то более интересное.

Идея пришла не сразу, было несколько реализаций прохождения, которые по времени, работали приблизительно по 3 минуты, после чего пришло озарение. А что, если искать не пути прохождения, а пути которые не ведут к прохождению лабиринта и помечать их как тупиковые.

Алгоритм такой:
Выполнять рекурсивную функцию по всем точкам дорог лабиринта:
1. Если мы стоим на дороге и вокруг нас 3 стены, помечаем место где мы стоим как тупик, в противном случае выходим из функции;
2. Переходим на место которое не является стенкой из пункта №1, и повторяем пункт №1;

Программная реализация:

...
var
  N:integer=600;
  LABIRINT:array[0..600,0..600] of integer;
...
procedure setBlankAsDeadblockRec(x,y:integer);
var k:integer;
begin
k:=0;
if LABIRINT[x,y]=blank then
  begin
  if LABIRINT[x-1,y]<>BLANK then k:=k+1;
  if LABIRINT[x,y-1]<>BLANK then k:=k+1;
  if LABIRINT[x+1,y]<>BLANK then k:=k+1;
  if LABIRINT[x,y+1]<>BLANK then k:=k+1;

  if k=4 then LABIRINT[x,y]:=DEADBLOCK;

  if k=3 then
    begin
    LABIRINT[x,y]:=DEADBLOCK;
    if LABIRINT[x-1,y]=BLANK then setBlankAsDeadblockRec(x-1,y);
    if LABIRINT[x,y-1]=BLANK then setBlankAsDeadblockRec(x,y-1);
    if LABIRINT[x+1,y]=BLANK then setBlankAsDeadblockRec(x+1,y);
    if LABIRINT[x,y+1]=BLANK then setBlankAsDeadblockRec(x,y+1);
    end;
  end;
end;

procedure setDeadblock;
var i,j:integer;
begin
for i:=1 to N-1 do
  for j:=1 to N-1 do
    setBlankAsDeadblockRec(i,j);
end;
...


Заключение


Я получил «полный» рабочий алгоритм, который можно использовать для поиска всех прохождений лабиринта. Последний по скорости работы превзошел все ожидания. Надеюсь моя маленькая работа, принесет кому-то пользу или подтолкнет к новым мыслям. И этому алгоритму есть куда стремиться, его можно сделать более быстрым, например если запускать рекурсивные функции в отдельных потоках. Поскольку функции являются достаточными, и не зависят друг от друга.

Программный код и пройденный лабиринт:
unit Unit1;

interface

uses
  Windows, Graphics, Forms, Dialogs, ExtCtrls, StdCtrls, Controls, Classes;

const
  WALL=-1;
  BLANK=-2;
  DEADBLOCK=-3;

type
  TForm1 = class(TForm)
    Button1: TButton;
    OpenDialog1: TOpenDialog;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  N:integer=600;
  LABIRINT:array[0..600,0..600] of integer;

implementation

{$R *.dfm}

procedure genBitmap;
var bit:TBitmap;
    i,j:Integer;
begin
bit:=TBitmap.Create;
bit.Width:=N+1;
bit.Height:=N+1;

for i:=0 to N do
  for j:=0 to N do
    begin
    if LABIRINT[i,j]=BLANK then bit.Canvas.Pixels[i,j]:=clWhite //
      else
        if LABIRINT[i,j]=WALL then bit.Canvas.Pixels[i,j]:=clBlack
          else bit.Canvas.Pixels[i,j]:=clRed;
    end;
  bit.SaveToFile('tmp.bmp');
  bit.Free;
end;

procedure rebuildArr2;
var i,j:integer;
begin
for i:=0 to ((N div 3) ) do
  for j:=0 to ((N div 3) ) do
    LABIRINT[i,j]:=LABIRINT[i*3,j*3];
N:=N div 3;
end;

procedure setBlankAsDeadblockRec(x,y:integer);
var k:integer;
begin
k:=0;
if LABIRINT[x,y]=blank then
  begin
  if LABIRINT[x-1,y]<>BLANK then k:=k+1;
  if LABIRINT[x,y-1]<>BLANK then k:=k+1;
  if LABIRINT[x+1,y]<>BLANK then k:=k+1;
  if LABIRINT[x,y+1]<>BLANK then k:=k+1;

  if k=4 then LABIRINT[x,y]:=DEADBLOCK;


  if k=3 then
    begin
    LABIRINT[x,y]:=DEADBLOCK;
    if LABIRINT[x-1,y]=BLANK then setBlankAsDeadblockRec(x-1,y);
    if LABIRINT[x,y-1]=BLANK then setBlankAsDeadblockRec(x,y-1);
    if LABIRINT[x+1,y]=BLANK then setBlankAsDeadblockRec(x+1,y);
    if LABIRINT[x,y+1]=BLANK then setBlankAsDeadblockRec(x,y+1);
    end;
  end;
end;

procedure setDeadblock;
var i,j:integer;
begin
for i:=1 to N-1 do
  for j:=1 to N-1 do
    setBlankAsDeadblockRec(i,j);
end;

procedure TForm1.Button1Click(Sender: TObject);
var bit:TBitmap;
    i,j:integer;
begin
bit:=TBitmap.Create;
If OpenDialog1.Execute then
  begin
  bit.LoadFromFile(OpenDialog1.FileName);
  for i:=0 to N do
    for j:=0 to N do
      if bit.Canvas.Pixels[j,i]=clWhite then
        LABIRINT[j,i]:=BLANK else LABIRINT[j,i]:=WALL;
  bit.Free;
  
  setDeadblock;
  genBitmap;
  end;
end;
end.






Для поиска кратчайшего пути, планируется применить волновой алгоритм к найденным прохождениям лабиринта. Было-бы интересно услышать, какие еще алгоритмы можно применить, для быстрого поиска пути в большом лабиринте?
Теги:
программирование, лабиринт, delphi

Данная статья не подлежит комментированию, поскольку её автор ещё не является полноправным участником сообщества. Вы сможете связаться с автором только после того, как он получит приглашение от кого-либо из участников сообщества. До этого момента его username будет скрыт псевдонимом.