<-- code -->

unit labgen1;

interface

uses
crt;
const
MAXX = 80;
MAXY = 40;
{границы лабиринта по иксу и игреку, т. к. этот рогалик шёл в 80*50, то лабиринт генерился соответствующих
размеров}
type
lab = array [1 .. MAXX, 1 .. MAXY] of integer;
{условия такие -- если значение ячейки равно 0, то данная клетка содержит стену; 1 -- пустое пространство, пол; 2 -- вход;
3 -- выход; 4 -- ловушка и т. д.}
var
startx, starty, finx, finy, temp01: integer;{startx, starty -- точка входа, finx, finy -- точка выхода}
procedure clearmemr(var b: lab);
procedure fillab(var a, b: lab);
procedure labgenmain(var a, b: lab; const MAXTRAPS: integer);
function pickpoint(lar, b: integer): char;
procedure showlab(a, b: lab);

{...skipped...}

procedure labgenmain(var a, b: lab; const MAXTRAPS: integer);
{Начальные параметры: a -- сам массив лабиринта; b -- массив, в котором складируется сколько раз где был персонаж, к делу
не относится, нужен лишь для вызова процедуры fillab; MAXTRAPS -- уровень сложности лабиринта (т. е. кол-во ловушек,
стен-иллюзий, открытых стен и т. д.)}
var
x, y, dx, dy: integer;
{x, y -- координаты, dx, dy -- смещение (дальше будет яснее)}
kw: longint;
{kw -- максимальное кол-во заполняемых точек массива (именно заполняемых полом, не всех!)}

function test1: boolean;
{тест на доступность клетки на заполнение, т. е. соответствие границам и незаполненность}
var
tr: boolean;
begin
tr := true;
if ((x + dx) * 2 < 1) or ((x + dx) * 2 > MAXX - 1) then tr := false;
if ((y + dy) * 2 < 1) or ((y + dy) * 2 > MAXY - 1) then tr := false;
if (a[(x + dx) * 2, (y + dy) * 2] <> 0) then tr := false;
test1 := tr;
end;

function test2: integer;
{выдаёт кол-во соседних незаполненых ячеек т. е. такое состояние
012345
1#####
2.###.
3..@##
4.#.##
5##.##
означает, что есть 2 соседние ячейки, в которые можно передвинуться: 3,1; 5,3.
}
var
tr: integer;
begin
tr := 0;
if ((a[x * 2 - 2, y * 2] = 0) and ((x * 2 - 2) > 1) and ((x * 2 - 2) < MAXX - 1)) then tr := tr + 1;
if ((a[x * 2 + 2, y * 2] = 0) and ((x * 2 + 2) > 1) and ((x * 2 + 2) < MAXX - 1)) then tr := tr + 1;
if ((a[x * 2, y * 2 - 2] = 0) and ((y * 2 - 2) > 1) and ((y * 2 - 2) < MAXY - 1)) then tr := tr + 1;
if ((a[x * 2, y * 2 + 2] = 0) and ((y * 2 + 2) > 1) and ((y * 2 + 2) < MAXY - 1)) then tr := tr + 1;
test2 := tr;
end;

function test3: boolean;
{проверяет клетку на возможность прохождения сквозь неё (пройти нельзя только сквозь стену -- 0)}
var
tr: boolean;
begin
tr := true;
if ((x + dx) * 2 < 1) or ((x + dx) * 2 > MAXX - 1) then tr := false;
if ((y + dy) * 2 < 1) or ((y + dy) * 2 > MAXY - 1) then tr := false;
if (a[(x + dx) * 2, (y + dy) * 2] = 0) then tr := false;
test3 := tr;
end;

function test4: boolean;
{проверяет на тупик: т. е. если в клетке [x, y] -- тупик, то возвращает true. Нужен мне был для генерации по закоулкам
призов, а так же входов и выходов (а то некрасиво, когда они просто рандомно по лабиринту валяются).}
var
tr: boolean;
begin
tr := true;
if ((a[x * 2, y * 2] <> 1) or (x < 1) or (x > MAXX) or (y < 1) or (y > MAXY)) then tr := false;
if test2 <> 3 then tr := false;
test4 := tr;
end;

function test5: boolean;
{тест, на нахождение пустой клетки между двумя стенами, т. е. тест на корридор. Нужен был для создавания незаметных
иллюзионных стен (иначе их очень легко заметить).}
var
tr: boolean;
begin
tr := false;
if ((a[x, y] = 1) and (x > 3) and (x < MAXX - 2) and (y > 3) and (y < MAXY - 2)) then
begin
tr := true;
if ((a[x - 1, y] = 0) and (a[x + 1, y] = 0)) then tr := true else
if ((a[x, y - 1] <> 0) and (a[x, y + 1] <> 0)) then tr := true
else tr := false;
end;
test5 := tr;
end;

{
Итак, вот краткое обяснение алгоритма по пунктам, для ясности:
1. Выбираем начало.
2. Чертим из него случайный след, до тех пор, пока он не упрётся сам в себя.
3. Как только упёрся -- выбираем другую точку на этом следе за начальную и чертим из него ответвление как по пункту 2.
4. Пункт 3 выполняется до тех пор, пока на карте не останется стен толще 1кл.

Начинаем:
}

begin
fillab(a, b);
{Заполняем массив лабиринта сплошной стеной.}
x := random(MAXX div 2);
y := random(MAXY div 2);
{Рандомно выбираем начальную точку. Причём, не из всех, а только из каждой второй.}
kw := (MAXX div 2 - 1) * (MAXY div 2 - 1);
{Вычисляем точное кол-во точек, куда можно встать (т. е. пустых), весь процесс генерации лабиринта будет состоять в
создании рандомных проходов между ними.}
while (kw > 0) do
{До тех пор пока не исчерпаем полностью запас этих самых точек делаем... (Если в конечном лабиринте будут незаполненные
точки, т. е. места, куда не сделан проход, стоит прибавить к kw. Если прибавить слишком много -- просто повиснет.)}
begin
dx := 0;
dy := 0;
{обнуляемся}
if random(2) = 1 then dx := (random(2) * 2) - 1 else dy := (random(2) * 2) - 1;
{рандомно выбираем между 1 и 0. В первом случае, будем рандомно продвигаться влево/вправо, иначе -- вверх/вниз}
if test1 then
{если в точке, в которую мы двигаемся -- стена, то...}
begin
a[x * 2 + dx, y * 2 + dy] := 1;
inc(x, dx);
inc(y, dy);
a[x * 2, y * 2] := 1;
dec(kw);
{...то заполняем её (и корридорчик ведущий в неё) полом, kw -= 1}
end;
if test2 = 0 then
{если мы в тупике и все соседние точки -- пустые, т. е. некуда больше двинуться (след замкнулся)...}
begin
dx:=0;
dy:=0;
if random(2) = 0 then dx := (random(2) * 2) - 1 else dy := (random(2) * 2) - 1;
{...рандомно выбираем одну из соседних точек...}
if test3 then
{...тестим её на то, что она -- не стенка и принадлежит границам лабиринта...}
begin
inc(x, dx);
inc(y, dy);
{.. и передвигаемся в неё}
end;
end;
end;
{таким образом заполняем весь массив. Генерация закончена.}

repeat
x := random(MAXX div 2);
y := random(MAXY div 2);
until test4;
startx := x * 2;
starty := y * 2;
a[x * 2, y * 2] := 2;
{располагаем вход в тупичке}
repeat
x := random(MAXX div 2);
y := random(MAXY div 2);
until test4;
finx := x * 2;
finy := y * 2;
a[x * 2, y * 2] := 3;
{располагаем выход в тупичке}

{далее будут раставляться ловушки, призы и стены-глюки, что уже не имеет отношения к делу}
for kw := 1 to MAXTRAPS do
begin
temp01 := 0;
repeat
x := random(MAXX div 2);
y := random(MAXY div 2);
temp01 := temp01 + 1;
until test4 or (temp01 = 50);
a[x * 2, y * 2] := 6;
end;
for kw := 1 to MAXTRAPS do
begin
repeat
x := random(MAXX);
y := random(MAXY);
until a[x, y] = 1;
a[x, y] := 4;
end;
for kw := 1 to MAXTRAPS do
begin
repeat
x := random(MAXX);
y := random(MAXY);
until test5;
a[x, y] := 5;
end;
end;

<-- code -->

Если тебе интересен результат этого метода -- качай Crypt (тот рогалик, в каком я всё это применял). Так же он был использован в игре Time of old ages, можешь глянуть.