514 lines
18 KiB
ObjectPascal
514 lines
18 KiB
ObjectPascal
unit Unit1;
|
||
|
||
{$mode objfpc}{$H+}
|
||
|
||
interface
|
||
|
||
uses
|
||
Classes, SysUtils, Forms, Controls, Graphics, Dialogs, ExtCtrls, StdCtrls,
|
||
MazeUnit;
|
||
|
||
const
|
||
CellSize = 50;
|
||
|
||
type
|
||
|
||
{ TForm1 }
|
||
|
||
TForm1 = class(TForm)
|
||
BackBuffer: TImage;
|
||
Button1: TButton;
|
||
Button2: TButton;
|
||
Button3: TButton;
|
||
Button4: TButton;
|
||
Button5: TButton;
|
||
Screen: TImage;
|
||
procedure Button1Click(Sender: TObject);
|
||
procedure Button2Click(Sender: TObject);
|
||
procedure Button3Click(Sender: TObject);
|
||
procedure Button4Click(Sender: TObject);
|
||
procedure Button5Click(Sender: TObject);
|
||
private
|
||
TheMaze: Maze;
|
||
public
|
||
|
||
end;
|
||
|
||
procedure ShowMaze(TheMaze: Maze); (* нарисовать лабиринт *)
|
||
procedure RecursiveSolve(TheMaze: Maze; xs, ys, xf, yf: Integer);
|
||
procedure WaveTracingSolve(TheMaze: Maze; xs, ys, xf, yf: Integer);
|
||
|
||
var
|
||
Form1: TForm1;
|
||
|
||
implementation
|
||
|
||
{$R *.lfm}
|
||
|
||
procedure ShowMaze(TheMaze: Maze); (* нарисовать лабиринт *)
|
||
var x, y: Integer;
|
||
Height, Width: Integer; (* высота и ширина лабиринта *)
|
||
begin
|
||
Width := High(TheMaze); (* определить высоту и ширину *)
|
||
Height := High(TheMaze[0]);
|
||
|
||
Form1.BackBuffer.Canvas.FillRect(Rect(0, 0, Form1.BackBuffer.Width, Form1.BackBuffer.Height));
|
||
for x := 0 to Width - 1 do
|
||
for y := 0 to Height - 1 do
|
||
begin
|
||
(* если в локации есть верхняя стена *)
|
||
if TheMaze[x, y].up_wall then
|
||
begin
|
||
(* рисуем ее *)
|
||
Form1.BackBuffer.Canvas.MoveTo(x * CellSize, y * CellSize);
|
||
Form1.BackBuffer.Canvas.LineTo((x + 1) * CellSize, y * CellSize)
|
||
end;
|
||
|
||
(* если в локации есть левая стена *)
|
||
if TheMaze[x, y].left_wall then
|
||
begin
|
||
(* рисуем и ее *)
|
||
Form1.BackBuffer.Canvas.MoveTo(x * CellSize, y * CellSize);
|
||
Form1.BackBuffer.Canvas.LineTo(x * CellSize, (y + 1) * CellSize)
|
||
end
|
||
end;
|
||
(* рисуем стену снизу и *)
|
||
Form1.BackBuffer.Canvas.MoveTo(0, Height * CellSize);
|
||
(* справа от лабиринта *)
|
||
Form1.BackBuffer.Canvas.LineTo(Width * CellSize, Height * CellSize);
|
||
Form1.BackBuffer.Canvas.LineTo(Width * CellSize, 0);
|
||
|
||
(* отобразить результат на основном экране *)
|
||
Form1.Screen.Canvas.CopyRect(
|
||
Rect(0, 0, Form1.Screen.Width, Form1.Screen.Height),
|
||
Form1.BackBuffer.Canvas,
|
||
Rect(0, 0, Form1.Screen.Width, Form1.Screen.Height));
|
||
end;
|
||
|
||
procedure RecursiveSolve(TheMaze: Maze; xs, ys, xf, yf: Integer);
|
||
var visited: array of array of Boolean; (* карта посещений локаций *)
|
||
x, y, xc, yc: Integer;
|
||
i: Integer;
|
||
Path: array of TPoint; (* Результирующий маршрут *)
|
||
Height, Width: Integer;
|
||
const dx: array[1..4] of Integer = (1, 0, -1, 0); (* смещения *)
|
||
dy: array[1..4] of Integer = (0, -1, 0, 1);
|
||
|
||
(* поиск финишной локации из точки (x, y) *)
|
||
function Solve(x, y, depth: Integer): Boolean;
|
||
var i: Integer;
|
||
begin
|
||
Visited[x, y] := true; (* пометить локцию как посещенную *)
|
||
Path[depth] := Point(x, y); (* добавить ее в описание маршрута *)
|
||
Path[depth + 1] := Point(-1, -1); (* добавить признак конца маршрута *)
|
||
|
||
if (x = xf) and (y = yf) then (* если финишная локация найдена *)
|
||
begin
|
||
Solve := true; (* Конец алгоритма *)
|
||
Exit;
|
||
end;
|
||
|
||
for i := 1 to 4 do
|
||
(* если дорожка свободна, идем по ней *)
|
||
if CanGo(TheMaze, x, y, dx[i], dy[i]) and not Visited[x + dx[i], y + dy[i]] then
|
||
if Solve(x + dx[i], y + dy[i], depth + 1) then
|
||
begin
|
||
Solve := true; (* если решение найдено *)
|
||
Exit; (* конец алгоритма *)
|
||
end;
|
||
|
||
Visited[x, y] := false; (* пометить локацию как непосещенную *)
|
||
Solve := false; (* решение найдено *)
|
||
end;
|
||
|
||
begin (* главная процедура *)
|
||
Width := High(TheMaze);
|
||
Height := High(TheMaze[0]);
|
||
SetLength(Path, Height * Width + 1); (* выделяем память для маршрута *)
|
||
SetLength(Visited, Width, Height); (* и для списка посещенных локаций *)
|
||
|
||
for x := 0 to Width - 1 do
|
||
for y := 0 to Height - 1 do
|
||
Visited[x, y] := false; (* изначально ни одна не посещена *)
|
||
|
||
if Solve(xs, ys, 0) then (* если найдено решение, рисуем его *)
|
||
begin
|
||
i := 0;
|
||
while not ((Path[i].x = -1) and (Path[i].y = -1)) do
|
||
begin
|
||
xc := CellSize * (2 * Path[i].x + 1) div 2;
|
||
yc := CellSize * (2 * Path[i].y + 1) div 2;
|
||
Form1.Screen.Canvas.Ellipse(xc - 5, yc - 5, xc + 5, yc + 5);
|
||
i := i + 1
|
||
end;
|
||
end;
|
||
|
||
end;
|
||
|
||
procedure WaveTracingSolve(TheMaze: Maze; xs, ys, xf, yf: Integer);
|
||
var Mark: array of array of Integer; (* метки локаций *)
|
||
x, y, xc, yc: Integer;
|
||
N, i: Integer;
|
||
Height, Width: Integer;
|
||
const dx: array[1..4] of Integer = (1, 0, -1, 0); (* смещений *)
|
||
dy: array[1..4] of Integer = (0, -1, 0, 1);
|
||
|
||
function Solve: Boolean; (* поиск решения *)
|
||
var i, N, x, y: Integer;
|
||
NoSolution: Boolean;
|
||
begin
|
||
N := 1; (* начинаем с итерации номер 1 *)
|
||
|
||
repeat
|
||
NoSolution := true; (* пессимистично полагаем, что решения нет *)
|
||
for x := 0 to Width - 1 do
|
||
for y := 0 to Height - 1 do
|
||
if Mark[x, y] = N then (* найти локации, помеченные числом N *)
|
||
for i := 1 to 4 do (* просмотр соседних локаций *)
|
||
if CanGo(TheMaze, x, y, dx[i], dy[i]) and (Mark[x + dx[i], y + dy[i]] = 0) then
|
||
begin (* локация доступна и помечена нулем *)
|
||
NoSolution := false; (* есть шанс найти решение *)
|
||
(* помечаем соседнюю локацию числом N + 1 *)
|
||
Mark[x + dx[i], y + dy[i]] := N + 1;
|
||
if (x + dx[i] = xf) and (y + dy[i] = yf) then
|
||
begin
|
||
Solve := true; (* дошло до финишной локации *)
|
||
Exit; (* конец алгоритма *)
|
||
end;
|
||
end;
|
||
N := N + 1; (* переход к следующей итерации *)
|
||
until NoSolution; (* повторять, если есть надежда найти решение *)
|
||
|
||
Solve := false; (* нет, решение не найдено *)
|
||
end;
|
||
|
||
begin
|
||
Width := High(TheMaze);
|
||
Height := High(TheMaze[0]);
|
||
SetLength(Mark, Width, Height); (* выделение памяти для пометок *)
|
||
|
||
for x := 0 to Width - 1 do (* изначально все заполняется нулями *)
|
||
for y := 0 to Height - 1 do
|
||
Mark[x, y] := 0;
|
||
|
||
Mark[xs, ys] := 1; (* стартовой локции соответствует единица *)
|
||
if Solve then (* если найдено решение, рисуем его *)
|
||
begin
|
||
x := xf;
|
||
y := yf;
|
||
for N := Mark[xf, yf] downto 1 do
|
||
begin
|
||
(* рисуем окружность на очередной локции маршрута *)
|
||
xc := CellSize * (2 * x + 1) div 2;
|
||
yc := CellSize * (2 * y + 1) div 2;
|
||
Form1.Screen.Canvas.Ellipse(xc - 5, yc - 5, xc + 5, yc + 5);
|
||
|
||
for i := 1 to 4 do
|
||
if CanGo(TheMaze, x, y, dx[i], dy[i]) and (Mark[x + dx[i], y + dy[i]] = N - 1) then
|
||
begin
|
||
x := x + dx[i]; (* ищем следующую локацию маршрута *)
|
||
y := y + dy[i];
|
||
Break;
|
||
end;
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
(* Генерация лабиринта по алгоритму Прима *)
|
||
function PrimGenerateMaze(Width, Height : Integer) : Maze;
|
||
type AttrType = (Inside, Outside, Border); (* тип "атрибут локации" *)
|
||
var
|
||
TheMaze: Maze; (* сам лабиринта *)
|
||
x, y, i: Integer;
|
||
xc, yc: Integer;
|
||
Attribute: array of array of AttrType; (* карта атрибутов *)
|
||
IsEnd: Boolean;
|
||
counter: Integer;
|
||
borders: array of TPoint;
|
||
borderToInside: TPoint;
|
||
const
|
||
dx: array[1..4] of Integer = (1, 0, -1, 0); (* смещения *)
|
||
dy : array[1..4] of Integer = (0, -1, 0, 1);
|
||
|
||
label ExitFor; (* используемые метки *)
|
||
|
||
procedure BreakWall(x, y, dx, dy : Integer); (* разрушить стену *)
|
||
begin (* между локациями *)
|
||
if dx = -1 then TheMaze[x, y].left_wall := false
|
||
else if dx = 1 then TheMaze[x + 1, y].left_wall := false
|
||
else if dy = -1 then TheMaze[x, y].up_wall := false
|
||
else TheMaze[x, y + 1].up_wall := false;
|
||
end;
|
||
|
||
begin
|
||
borders := nil;
|
||
SetLength(Attribute, Width, Height); (* выделение памяти для атрибутов *)
|
||
SetLength(TheMaze, Width + 1, Height + 1); (* изменить размер лабиринта *)
|
||
|
||
for x := 0 to Width - 1 do (* изначально все атрибуты *)
|
||
for y := 0 to Height - 1 do (* равны Outside *)
|
||
Attribute[x, y] := Outside;
|
||
|
||
for y := 0 to Height do (* все стены изначально *)
|
||
for x := 0 to Width do (* существуют *)
|
||
begin
|
||
TheMaze[x, y].left_wall := true;
|
||
TheMaze[x, y].up_wall := true;
|
||
end;
|
||
|
||
Randomize;
|
||
x := Random(Width); (* выбираем начальную локацию *)
|
||
y := Random(Height);
|
||
Attribute[x, y] := Inside; (* и присваиваем ей атрибут Inside *)
|
||
|
||
for i := 1 to 4 do (* всем ее соседям присваиваем *)
|
||
begin (* атрибут Border *)
|
||
xc := x + dx[i];
|
||
yc := y + dy[i];
|
||
if (xc >= 0) and (yc >= 0) and (xc < Width) and (yc < Height) then
|
||
begin
|
||
SetLength(borders, Length(borders) + 1);
|
||
borders[Length(borders) - 1].X := xc;
|
||
borders[Length(borders) - 1].Y := yc;
|
||
Attribute[xc, yc] := Border
|
||
end
|
||
end;
|
||
|
||
repeat (* главный цикл *)
|
||
IsEnd := true;
|
||
counter := Length(borders);
|
||
|
||
(* Выбираем из них одну случайную. *)
|
||
counter := Random(counter);
|
||
borderToInside := borders[counter];
|
||
|
||
(* Удаляем локацию с атрибутом Border из списка. *)
|
||
Move(borders[counter + 1], borders[counter], SizeOf(TPoint) * (Length(borders) - counter - 1));
|
||
SetLength(borders, Length(borders) - 1);
|
||
|
||
(* Присвоить ей атрибут Inside. *)
|
||
Attribute[borderToInside.X, borderToInside.Y] := Inside;
|
||
|
||
counter := 0;
|
||
for i := 1 to 4 do
|
||
begin
|
||
xc := borderToInside.X + dx[i];
|
||
yc := borderToInside.Y + dy[i];
|
||
if (xc >= 0) and (yc >= 0) and (xc < Width) and (yc < Height) then
|
||
begin (* подсчитать количество локаций с атрибутом Inside *)
|
||
if Attribute[xc, yc] = Inside then counter := counter + 1;
|
||
if Attribute[xc, yc] = Outside then
|
||
begin
|
||
(* Заменить атрибуты с Outside на Border. *)
|
||
SetLength(borders, Length(borders) + 1);
|
||
borders[Length(borders) - 1].X := xc;
|
||
borders[Length(borders) - 1].Y := yc;
|
||
Attribute[xc, yc] := Border;
|
||
end
|
||
end;
|
||
end;
|
||
|
||
counter := Random(counter) + 1; (* выбрать случайную Inside-локацию *)
|
||
for i := 1 to 4 do
|
||
begin
|
||
xc := borderToInside.X + dx[i];
|
||
yc := borderToInside.Y + dy[i];
|
||
if (xc >= 0) and (yc >= 0) and (xc < Width) and (yc < Height)
|
||
and (Attribute[xc, yc] = Inside) then
|
||
begin
|
||
counter := counter - 1;
|
||
if counter = 0 then (* разрушить стену между ней и *)
|
||
begin (* текущей локацией *)
|
||
BreakWall(borderToInside.X, borderToInside.y, dx[i], dy[i]);
|
||
goto ExitFor
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
ExitFor:
|
||
(* Определить, есть ли хоть одна локация с атрибутом Border. *)
|
||
if Length(borders) > 0 then
|
||
begin
|
||
(* Если да, продолжаем выполнять алгоритм. *)
|
||
IsEnd := false
|
||
end;
|
||
|
||
ShowMaze(TheMaze); (* отобразить процесс генерации *)
|
||
Application.ProcessMessages;
|
||
until IsEnd;
|
||
PrimGenerateMaze := TheMaze;
|
||
end;
|
||
|
||
(* Генерация лабиринта по алгоритму Краскала *)
|
||
function KruskalGenerateMaze(Width, Height : Integer) : Maze;
|
||
type Wall = record (* тип "стена" *)
|
||
x, y, dx, dy : Integer;
|
||
end;
|
||
var TheMaze: Maze; (* сам лабиринт *)
|
||
Walls: array of Wall; (* массив стен *)
|
||
Temp: array of Real; (* временный массив для сортироваки стен *)
|
||
i, j: Integer;
|
||
tempw: Wall;
|
||
tempr: Real;
|
||
CurWall: Wall;
|
||
locations: Integer;
|
||
counter: Integer;
|
||
|
||
procedure BreakWall(x, y, dx, dy : Integer); (* разрушить стену *)
|
||
begin (* между локациями *)
|
||
if dx = -1 then TheMaze[x, y].left_wall := false
|
||
else if dx = 1 then TheMaze[x + 1, y].left_wall := false
|
||
else if dy = -1 then TheMaze[x, y].up_wall := false
|
||
else TheMaze[x, y + 1].up_wall := false;
|
||
end;
|
||
|
||
function IsConnected(xs, ys, xf, yf : Integer) : Boolean;
|
||
(* используем алгоритм волновой трассировки *)
|
||
var Mark: array of array of Integer;
|
||
x, y: Integer;
|
||
Height, Width: Integer;
|
||
const dx : array[1..4] of Integer = (1, 0, -1, 0);
|
||
dy : array[1..4] of Integer = (0, -1, 0, 1);
|
||
|
||
function CanGo(x, y, dx, dy : Integer) : Boolean;
|
||
begin
|
||
if dx = -1 then CanGo := not TheMaze[x, y].left_wall
|
||
else if dx = 1 then CanGo := not TheMaze[x + 1, y].left_wall
|
||
else if dy = -1 then CanGo := not TheMaze[x, y].up_wall
|
||
else CanGo := not TheMaze[x, y + 1].up_wall;
|
||
end;
|
||
|
||
function Solve : Boolean;
|
||
var i, N, x, y : Integer;
|
||
NoSolution : Boolean;
|
||
begin
|
||
N := 1;
|
||
|
||
repeat
|
||
NoSolution := true;
|
||
for x := 0 to Width - 1 do
|
||
for y := 0 to Height - 1 do
|
||
if Mark[x, y] = N then
|
||
for i := 1 to 4 do
|
||
if CanGo(x, y, dx[i], dy[i]) and (Mark[x + dx[i], y + dy[i]] = 0) then
|
||
begin
|
||
NoSolution := false;
|
||
|
||
Mark[x + dx[i], y + dy[i]] := N + 1;
|
||
if (x + dx[i] = xf) and (y + dy[i] = yf) then
|
||
begin
|
||
Solve := true;
|
||
Exit;
|
||
end;
|
||
end;
|
||
N := N + 1;
|
||
until NoSolution;
|
||
|
||
Solve := false;
|
||
end;
|
||
|
||
begin
|
||
Width := High(TheMaze);
|
||
Height := High(TheMaze[0]);
|
||
SetLength(Mark, Width, Height);
|
||
|
||
for x := 0 to Width - 1 do
|
||
for y := 0 to Height - 1 do
|
||
Mark[x, y] := 0;
|
||
|
||
Mark[xs, ys] := 1;
|
||
IsConnected := Solve;
|
||
end;
|
||
|
||
begin
|
||
(* выделение памяти для массива стен
|
||
в лабиринте Width * Height изначально
|
||
(Width - 1) * Height + (Height - 1) * Width стен *)
|
||
SetLength(Walls, (Width - 1) * Height + (Height - 1) * Width);
|
||
SetLength(Temp, (Width - 1) * Height + (Height - 1) * Width);
|
||
SetLength(TheMaze, Width + 1, Height + 1); (* указать размер лабиринта *)
|
||
|
||
for i := 0 to Width do (* все стены изначально *)
|
||
for j := 0 to Height do (* существуют *)
|
||
begin
|
||
TheMaze[i, j].left_wall := true;
|
||
TheMaze[i, j].up_wall := true;
|
||
end;
|
||
|
||
Randomize;
|
||
for i := 0 to (Width - 1) * Height + (Height - 1) * Width - 1 do
|
||
Temp[i] := Random; (* заполнение массива Temp случайными числами *)
|
||
|
||
counter := 0; (* заполнение массива стен *)
|
||
for i := 1 to Width - 1 do
|
||
for j := 0 to Height - 1 do
|
||
begin (* сначала все горизонтальные *)
|
||
Walls[counter].x := i; Walls[counter].y := j;
|
||
Walls[counter].dx := -1; Walls[counter].dy := 0;
|
||
counter := counter + 1;
|
||
end;
|
||
for i := 0 to Width - 1 do
|
||
for j := 1 to Height - 1 do
|
||
begin (* затем все вертикальные *)
|
||
Walls[counter].x := i; Walls[counter].y := j;
|
||
Walls[counter].dx := 0; Walls[counter].dy := -1;
|
||
counter := counter + 1;
|
||
end;
|
||
|
||
for i := 0 to (Width - 1) * Height + (Height - 1) * Width - 1 do
|
||
for j := i to (Width - 1) * Height + (Height - 1) * Width - 1 do
|
||
if Temp[i] > Temp[j] then (* перемешиваем массив стен *)
|
||
begin
|
||
tempr := Temp[i]; Temp[i] := Temp[j]; Temp[j] := tempr;
|
||
tempw := Walls[i]; Walls[i] := Walls[j]; Walls[j] := tempw;
|
||
end;
|
||
|
||
locations := Width * Height;
|
||
i := 0;
|
||
while locations > 1 do (* прямолинейная реализация *)
|
||
begin (* алгоритма Краскала *)
|
||
CurWall := Walls[i];
|
||
i := i + 1;
|
||
if not IsConnected(CurWall.x, CurWall.y, CurWall.x + CurWall.dx, CurWall.y + CurWall.dy) then
|
||
begin
|
||
BreakWall(CurWall.x, CurWall.y, CurWall.dx, CurWall.dy);
|
||
locations := locations - 1;
|
||
ShowMaze(TheMaze);
|
||
Application.ProcessMessages;
|
||
end;
|
||
end;
|
||
|
||
KruskalGenerateMaze := TheMaze;
|
||
end;
|
||
|
||
{ TForm1 }
|
||
|
||
procedure TForm1.Button1Click(Sender: TObject);
|
||
begin
|
||
LoadMaze(TheMaze, 'sample.txt');
|
||
ShowMaze(TheMaze)
|
||
end;
|
||
|
||
procedure TForm1.Button2Click(Sender: TObject);
|
||
begin
|
||
RecursiveSolve(TheMaze, 0, 0, 4, 0)
|
||
end;
|
||
|
||
procedure TForm1.Button3Click(Sender: TObject);
|
||
begin
|
||
WaveTracingSolve(TheMaze, 0, 0, 4, 0)
|
||
end;
|
||
|
||
procedure TForm1.Button4Click(Sender: TObject);
|
||
begin
|
||
PrimGenerateMaze(30, 18)
|
||
end;
|
||
|
||
procedure TForm1.Button5Click(Sender: TObject);
|
||
begin
|
||
KruskalGenerateMaze(30, 18)
|
||
end;
|
||
|
||
end.
|
||
|