Закончил 4-е упражнение 4-й главы
This commit is contained in:
513
Занимательное программирование/4/4_prim/unit1.pas
Normal file
513
Занимательное программирование/4/4_prim/unit1.pas
Normal file
@@ -0,0 +1,513 @@
|
||||
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.
|
||||
|
||||
Reference in New Issue
Block a user