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

Алгоритмы*, Программирование*

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

Предыстория

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

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

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

История

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

const

WALL=-1;

BLANK=-2;

DEADBLOCK=-3;

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

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

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

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. Генерируем перестроенное изображение.

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

И так, у нас есть изображение лабиринта нужного вида, теперь самое интересное, поиск всех вариантов прохождения лабиринта. Что у нас есть? Массив с записанными значениями 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;

...

13 ----------------------------------------

14