From b7a63ee8956d977ad3364a1d8f509e307232a22a Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Sun, 28 Dec 2025 19:31:39 +0100 Subject: =?UTF-8?q?=D0=97=D0=B0=D0=BA=D0=BE=D0=BD=D1=87=D0=B8=D0=BB=204-?= =?UTF-8?q?=D0=B5=20=D1=83=D0=BF=D1=80=D0=B0=D0=B6=D0=BD=D0=B5=D0=BD=D0=B8?= =?UTF-8?q?=D0=B5=204-=D0=B9=20=D0=B3=D0=BB=D0=B0=D0=B2=D1=8B?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- .../4/4_prim/unit1.pas" | 513 +++++++++++++++++++++ 1 file changed, 513 insertions(+) create mode 100644 "\320\227\320\260\320\275\320\270\320\274\320\260\321\202\320\265\320\273\321\214\320\275\320\276\320\265 \320\277\321\200\320\276\320\263\321\200\320\260\320\274\320\274\320\270\321\200\320\276\320\262\320\260\320\275\320\270\320\265/4/4_prim/unit1.pas" (limited to 'Занимательное программирование/4/4_prim/unit1.pas') diff --git "a/\320\227\320\260\320\275\320\270\320\274\320\260\321\202\320\265\320\273\321\214\320\275\320\276\320\265 \320\277\321\200\320\276\320\263\321\200\320\260\320\274\320\274\320\270\321\200\320\276\320\262\320\260\320\275\320\270\320\265/4/4_prim/unit1.pas" "b/\320\227\320\260\320\275\320\270\320\274\320\260\321\202\320\265\320\273\321\214\320\275\320\276\320\265 \320\277\321\200\320\276\320\263\321\200\320\260\320\274\320\274\320\270\321\200\320\276\320\262\320\260\320\275\320\270\320\265/4/4_prim/unit1.pas" new file mode 100644 index 0000000..e43eb9c --- /dev/null +++ "b/\320\227\320\260\320\275\320\270\320\274\320\260\321\202\320\265\320\273\321\214\320\275\320\276\320\265 \320\277\321\200\320\276\320\263\321\200\320\260\320\274\320\274\320\270\321\200\320\276\320\262\320\260\320\275\320\270\320\265/4/4_prim/unit1.pas" @@ -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. + -- cgit v1.2.3