Главная

Алгоритм поиска путей в лабиринте

2013-10-21 в 7:50, admin, рубрики: Алгоритмы, алгоритмы поиска, Лабиринт, Программирование, метки: Алгоритмы, алгоритмы поиска, Лабиринт, Программирование

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

Пред история

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

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

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

История

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

Алгоритм поиска путей в лабиринте

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

Автор: MaxiMonster

Источник