path: root/Занимательное программирование/4/4_prim/unit1.pas

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.