belka/book-exercises
1
0
Fork 0
Code Issues Pull Requests Activity

Закончил 4-е упражнение 4-й главы

Browse Source
This commit is contained in:
Eugen Wissner
2025-12-28 19:31:39 +01:00
parent 2a9136b2f3
commit b7a63ee895
9 changed files with 999 additions and 2 deletions
Download Patch File Download Diff File Expand all files Collapse all files

BIN
Занимательное программирование/4/4_prim/labyrinth.ico Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 61 KiB

90
Занимательное программирование/4/4_prim/labyrinth.lpi Normal file
View File

@@ -0,0 +1,90 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="12"/>
<PathDelim Value="\"/>
<General>
<SessionStorage Value="InProjectDir"/>
<Title Value="labyrinth"/>
<Scaled Value="True"/>
<ResourceType Value="res"/>
<UseXPManifest Value="True"/>
<XPManifest>
<DpiAware Value="True"/>
</XPManifest>
<Icon Value="0"/>
</General>
<BuildModes>
<Item Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
<UseFileFilters Value="True"/>
</PublishOptions>
<RunParams>
<FormatVersion Value="2"/>
</RunParams>
<RequiredPackages>
<Item>
<PackageName Value="LCL"/>
</Item>
</RequiredPackages>
<Units>
<Unit>
<Filename Value="labyrinth.lpr"/>
<IsPartOfProject Value="True"/>
</Unit>
<Unit>
<Filename Value="unit1.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="Form1"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
<UnitName Value="Unit1"/>
</Unit>
<Unit>
<Filename Value="maze.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="MazeUnit"/>
</Unit>
<Unit>
<Filename Value="sample.txt"/>
<IsPartOfProject Value="True"/>
</Unit>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="labyrinth"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Linking>
<Debugging>
<DebugInfoType Value="dsDwarf3"/>
</Debugging>
<Options>
<Win32>
<GraphicApplication Value="True"/>
</Win32>
</Options>
</Linking>
</CompilerOptions>
<Debugging>
<Exceptions>
<Item>
<Name Value="EAbort"/>
</Item>
<Item>
<Name Value="ECodetoolError"/>
</Item>
<Item>
<Name Value="EFOpenError"/>
</Item>
</Exceptions>
</Debugging>
</CONFIG>

28
Занимательное программирование/4/4_prim/labyrinth.lpr Normal file
View File

@@ -0,0 +1,28 @@
program labyrinth;
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}
cthreads,
{$ENDIF}
{$IFDEF HASAMIGA}
athreads,
{$ENDIF}
Interfaces, // this includes the LCL widgetset
Forms, Unit1, MazeUnit
{ you can add units after this };
{$R *.res}
begin
RequireDerivedFormResource:=True;
Application.Scaled:=True;
{$PUSH}{$WARN 5044 OFF}
Application.MainFormOnTaskbar:=True;
{$POP}
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.

189
Занимательное программирование/4/4_prim/labyrinth.lps Normal file
View File

@@ -0,0 +1,189 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectSession>
<PathDelim Value="\"/>
<Version Value="12"/>
<BuildModes Active="Default"/>
<Units>
<Unit>
<Filename Value="labyrinth.lpr"/>
<IsPartOfProject Value="True"/>
<EditorIndex Value="3"/>
<CursorPos X="25" Y="13"/>
<UsageCount Value="29"/>
<Loaded Value="True"/>
</Unit>
<Unit>
<Filename Value="unit1.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="Form1"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
<UnitName Value="Unit1"/>
<IsVisibleTab Value="True"/>
<TopLine Value="227"/>
<CursorPos X="14" Y="233"/>
<UsageCount Value="29"/>
<Loaded Value="True"/>
<LoadedDesigner Value="True"/>
</Unit>
<Unit>
<Filename Value="maze.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="MazeUnit"/>
<EditorIndex Value="-1"/>
<CursorPos X="27" Y="7"/>
<UsageCount Value="29"/>
</Unit>
<Unit>
<Filename Value="sample.txt"/>
<IsPartOfProject Value="True"/>
<EditorIndex Value="2"/>
<CursorPos X="4" Y="21"/>
<UsageCount Value="29"/>
<Loaded Value="True"/>
<DefaultSyntaxHighlighter Value="Text"/>
</Unit>
<Unit>
<Filename Value="mazeunit.pas"/>
<UnitName Value="MazeUnit"/>
<EditorIndex Value="1"/>
<CursorPos X="19" Y="26"/>
<UsageCount Value="15"/>
<Loaded Value="True"/>
</Unit>
<Unit>
<Filename Value="C:\opt\lazarus\fpc\3.2.2\source\rtl\objpas\classes\classesh.inc"/>
<EditorIndex Value="-1"/>
<CursorPos X="4" Y="27"/>
<UsageCount Value="10"/>
</Unit>
</Units>
<JumpHistory HistoryIndex="29">
<Position>
<Filename Value="unit1.pas"/>
<Caret Line="328" Column="88" TopLine="310"/>
</Position>
<Position>
<Filename Value="unit1.pas"/>
<Caret Line="471" Column="33" TopLine="454"/>
</Position>
<Position>
<Filename Value="unit1.pas"/>
<Caret Line="473" Column="22" TopLine="471"/>
</Position>
<Position>
<Filename Value="unit1.pas"/>
<Caret Line="474" Column="3" TopLine="473"/>
</Position>
<Position>
<Filename Value="unit1.pas"/>
<Caret Line="503" Column="30" TopLine="420"/>
</Position>
<Position>
<Filename Value="unit1.pas"/>
<Caret Line="187" TopLine="187"/>
</Position>
<Position>
<Filename Value="unit1.pas"/>
<Caret Line="320" Column="24" TopLine="298"/>
</Position>
<Position>
<Filename Value="unit1.pas"/>
<Caret Line="460" Column="19" TopLine="457"/>
</Position>
<Position>
<Filename Value="unit1.pas"/>
<Caret Line="493" Column="14" TopLine="468"/>
</Position>
<Position>
<Filename Value="unit1.pas"/>
<Caret Line="39" Column="22" TopLine="24"/>
</Position>
<Position>
<Filename Value="mazeunit.pas"/>
<Caret Line="14" Column="33"/>
</Position>
<Position>
<Filename Value="mazeunit.pas"/>
<Caret Line="72" Column="25" TopLine="55"/>
</Position>
<Position>
<Filename Value="mazeunit.pas"/>
<Caret Line="17" Column="16"/>
</Position>
<Position>
<Filename Value="mazeunit.pas"/>
<Caret Line="25" Column="16"/>
</Position>
<Position>
<Filename Value="unit1.pas"/>
<Caret Line="11"/>
</Position>
<Position>
<Filename Value="sample.txt"/>
<Caret Line="5" Column="9"/>
</Position>
<Position>
<Filename Value="unit1.pas"/>
<Caret Line="472" Column="33" TopLine="458"/>
</Position>
<Position>
<Filename Value="unit1.pas"/>
<Caret Line="483" Column="11" TopLine="458"/>
</Position>
<Position>
<Filename Value="unit1.pas"/>
<Caret Line="37" Column="19" TopLine="22"/>
</Position>
<Position>
<Filename Value="unit1.pas"/>
<Caret Line="28" Column="67" TopLine="16"/>
</Position>
<Position>
<Filename Value="unit1.pas"/>
<Caret Line="39" Column="22" TopLine="16"/>
</Position>
<Position>
<Filename Value="unit1.pas"/>
<Caret Line="148" Column="22" TopLine="123"/>
</Position>
<Position>
<Filename Value="unit1.pas"/>
<Caret Line="356" Column="36" TopLine="356"/>
</Position>
<Position>
<Filename Value="unit1.pas"/>
<Caret Line="498" Column="7" TopLine="473"/>
</Position>
<Position>
<Filename Value="unit1.pas"/>
<Caret Line="14" Column="27" TopLine="7"/>
</Position>
<Position>
<Filename Value="unit1.pas"/>
<Caret Line="46" Column="27" TopLine="34"/>
</Position>
<Position>
<Filename Value="unit1.pas"/>
<Caret Line="268" Column="56" TopLine="254"/>
</Position>
<Position>
<Filename Value="unit1.pas"/>
<Caret Line="338" Column="10" TopLine="323"/>
</Position>
<Position>
<Filename Value="unit1.pas"/>
<Caret Line="223" Column="19" TopLine="213"/>
</Position>
<Position>
<Filename Value="unit1.pas"/>
<Caret Line="287" Column="17" TopLine="269"/>
</Position>
</JumpHistory>
<RunParams>
<FormatVersion Value="2"/>
<Modes ActiveMode=""/>
</RunParams>
</ProjectSession>
</CONFIG>

85
Занимательное программирование/4/4_prim/mazeunit.pas Normal file
View File

@@ -0,0 +1,85 @@
unit MazeUnit;
{$mode ObjFPC}{$H+}
interface
uses
Classes, SysUtils;
type
Location = record
left_wall, up_wall: Boolean;
end;
Maze = array of array of Location;
(* Загрузить лабиринт. *)
procedure LoadMaze(var TheMaze: Maze; FileName: string);
(* Сохранить лабиринт *)
procedure SaveMaze(TheMaze: Maze; FileName: string);
function CanGo(TheMaze: Maze; x, y, dx, dy: Integer): Boolean;
implementation
procedure LoadMaze(var TheMaze: Maze; FileName: string);
var f: TextFile; (* Файл с описанием лабиринта *)
Height, Width: Integer; (* высота и ширина лабиринта *)
x, y: Integer; (* текущая локация *)
lw, uw: Integer; (* временные переменные *)
begin
AssignFile(f, FileName); (* открыть файл *)
Reset(f);
ReadLn(f, Width, Height); (* прочитать высоту и ширину *)
SetLength(TheMaze, Width + 1, Height + 1); (* изменить размер лабиринта *)
for y := 0 to Height do (* Цикл по всем локациям *)
for x := 0 to Width do
if (y = Height) or (x = Width) then (* если локация - служебная *)
begin
TheMaze[x, y].left_wall := true; (* обе стены существуют *)
TheMaze[x, y].up_wall := true
end
else
begin (* иначе считываем *)
ReadLn(f, uw, lw); (* из файла *)
TheMaze[x, y].left_wall := Boolean(lw); (* прочитанное целое *)
TheMaze[x, y].up_wall := Boolean(uw); (* число надо привести *)
end; (* к типу Boolean *)
CloseFile(f); (* Закрыть файл *)
end;
procedure SaveMaze(TheMaze: Maze; FileName: string);
var f: TextFile; (* файл с описанием лабиринта *)
Height, Width: Integer; (* высота и ширина *)
x, y: Integer; (* координаты текущей локации *)
begin
AssignFile(f, FileName); (* открыать файл *)
Rewrite(f); (* для записи *)
Height := High(TheMaze[0]); (* определяем высоту *)
Width := High(TheMaze); (* и ширину лабиринта *)
WriteLn(f, Width, ' ', Height); (* запись в файл высоты и ширины *)
for y := 0 to Height - 1 do
for x := 0 to Width - 1 do
WriteLn(f, Integer(TheMaze[x, y].up_wall), ' ',
Integer(TheMaze[x, y].left_wall));
CloseFile(f); (* закрыть файл *)
end;
(* служебная функция: определяет, можно ли пройти из локации
(x, y) в локацию (x + dx, y + dy), то есть нет ли между ними стены *)
function CanGo(TheMaze: Maze; 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;
end.

21
Занимательное программирование/4/4_prim/sample.txt Normal file
View File

@@ -0,0 +1,21 @@
5 4
1 1
1 1
1 0
1 1
1 0
0 1
1 0
0 1
0 0
1 1
0 1
1 0
1 0
0 0
0 0
1 1
0 0
0 1
0 1
0 1

69
Занимательное программирование/4/4_prim/unit1.lfm Normal file
View File

@@ -0,0 +1,69 @@
object Form1: TForm1
Left = 322
Height = 620
Top = 32
Width = 856
Caption = 'Form1'
ClientHeight = 620
ClientWidth = 856
DesignTimePPI = 120
LCLVersion = '4.2.0.0'
object BackBuffer: TImage
Left = 16
Height = 400
Top = 8
Width = 824
Visible = False
end
object Screen: TImage
Left = 16
Height = 400
Top = 8
Width = 824
end
object Button1: TButton
Left = 16
Height = 56
Top = 440
Width = 176
Caption = 'Загрузка/сохранение'
TabOrder = 0
OnClick = Button1Click
end
object Button2: TButton
Left = 192
Height = 56
Top = 440
Width = 166
Caption = 'Рекурсивный обход'
TabOrder = 1
OnClick = Button2Click
end
object Button3: TButton
Left = 360
Height = 56
Top = 440
Width = 176
Caption = 'Волновая трассировка'
TabOrder = 2
OnClick = Button3Click
end
object Button4: TButton
Left = 536
Height = 56
Top = 440
Width = 144
Caption = 'Алгоритм Прима'
TabOrder = 3
OnClick = Button4Click
end
object Button5: TButton
Left = 680
Height = 56
Top = 440
Width = 160
Caption = 'Алгоритм Краскала'
TabOrder = 4
OnClick = Button5Click
end
end

513
Занимательное программирование/4/4_prim/unit1.pas Normal file
View 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.

6
Занимательное программирование/README.txt
View File

@@ -5,5 +5,7 @@ Pascal или Delphi, в моем случае это Free Pascal и Lazarus.
В первой главе ("Компьютерное моделирование") есть один С файл (для
рисования применяется Cairo).
Вторая ("Анимация и графические эффекты") и четвертая ("Трехмерная
графика") главы основывается на Java и игровом движке libGDX.
Вторая глава ("Анимация и графические эффекты") основывается на Java и
игровом движке libGDX.
Четвертая глава ("Трехмерная графика") сделана с Pascal и libGDX.