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

Пред история

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

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

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

История

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

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