Pull to refresh

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

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

Предистория


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

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



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

История


Для удобного решения, необходимо имеющееся изображение лабиринта, привести к типу двумерного массива. Каждый элемент которого может принять одно из 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.






Для поиска кратчайшего пути, планируется применить волновой алгоритм к найденным прохождениям лабиринта. Было-бы интересно услышать, какие еще алгоритмы можно применить, для быстрого поиска пути в большом лабиринте?
Tags:
Hubs:
You can’t comment this publication because its author is not yet a full member of the community. You will be able to contact the author only after he or she has been invited by someone in the community. Until then, author’s username will be hidden by an alias.