Zufalls Labyrinth (dynamisch) erstellen

[Phantom1]

Ich habe schonmal ein dynamisches Labyrinth programmiert, du brauchst dazu ein TImage, ein TButton und eine TCheckbox.

hier der Code von mir:

Delphi-Quellcode:

Unit Unit1;

Interface

Uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ExtCtrls;

Type
  TCellType = Set Of (cStart, cFinal, cSolution, cFree);

  TForm1 = Class(TForm)
    Button1: TButton;
    Image1: TImage;
    CheckBox1: TCheckBox; // zum anzeigen des Lösungsweges
    Procedure Button1Click(Sender: TObject);
    procedure CheckBox1Click(Sender: TObject);
  Private
    Cells: Array[0..49, 0..49] Of Record S, O: Boolean; CellType: TCellType End;
    Procedure GenerateMaze(StartX, StartY: Integer);
    Procedure DrawMaze(ShowSolution: Boolean); 
  End;

Var
  Form1: TForm1;

Implementation

{$R *.DFM}

Procedure TForm1.Button1Click(Sender: TObject);
Begin
  Randomize;
  //RandSeed:=0;
  Caption:=IntToStr(RandSeed);
  // Labyrinth erstellen mit zufälliger Startposition
  GenerateMaze(Random(High(Cells)),0);
  // Labyrinth anzeigen
  DrawMaze(CheckBox1.Checked);
End;

procedure TForm1.DrawMaze(ShowSolution: Boolean);
Var x, y: Integer;
begin
  Image1.Picture.Bitmap:=Nil;
  Image1.Width:=501;
  Image1.Height:=501;
  With Image1.Canvas Do Begin
    Brush.Color:=clBlack;
    FrameRect(ClipRect);
    Pen.Width:=1;
    Pen.Color:=clBlack;
    For x:=0 to High(Cells) Do
      For y:=0 to High(Cells[0]) Do Begin
        If Cells[x,y].O Then Begin
          MoveTo((x+1)*10, y*10);
          LineTo((x+1)*10, (y+1)*10+1)
        End;
        If Cells[x,y].S Then Begin
          MoveTo(x*10, (y+1)*10);
          LineTo((x+1)*10+1, (y+1)* 10)
        End;
        If cStart In Cells[x,y].CellType Then
          Ellipse(x*10+2, y*10+2, x*10+8, y*10+8);
        If cFinal In Cells[x,y].CellType Then
          Ellipse(x*10+2, y*10+2, x*10+8, y*10+8);
        If ShowSolution And (cSolution In Cells[x,y].CellType) Then
          Ellipse(x*10+4, y*10+4, x*10+6, y*10+6);
      End;
  End;
end;

Procedure TForm1.GenerateMaze(StartX, StartY: Integer);
CONST N=0; S=1; W=2; O=3;

  Function ValidCell(x, y: Integer): Boolean;
  Begin
    Result:=(x>=0) And (y>=0) And (x<=High(Cells)) And (y<=High(Cells[0]));
  End;

  Function ValidWay(x, y: Integer): Boolean;
  Begin
    If ValidCell(x,y) Then Result:=cFree In Cells[x,y].CellType
    Else Result:=False;
  End;

  Function NewWay(x, y, r: Integer): Boolean;
  Var WegNr: Array[0..3] Of Boolean; Solution: Boolean; Nr: Byte;
  Begin
    // die aktuelle Zelle als belegt markieren
    Cells[x,y].CellType:=Cells[x,y].CellType-[cFree];
    // die Wand entfernen, aus der Richtung der wir gekommen sind
    Case r Of
      S: If ValidCell(x,y-1) Then Cells[x,y-1].S:=False;
      N: Cells[x,y].S:=False;
      O: If ValidCell(x-1,y) Then Cells[x-1,y].O:=False;
      W: Cells[x,y].O:=False;
    End;
    // Zufällige Reihenfolge der Richtungen berechnen
    For Nr:=0 To 3 Do WegNr[Nr]:=False;
    Solution:=False;
    Repeat
      Nr:=Random(4);
      Case Nr Of
        N: If ValidWay(x,y-1) Then Solution:=NewWay(x,y-1,N);
        S: If ValidWay(x,y+1) Then Solution:=NewWay(x,y+1,S);
        W: If ValidWay(x-1,y) Then Solution:=NewWay(x-1,y,W);
        O: If ValidWay(x+1,y) Then Solution:=NewWay(x+1,y,O);
      End;
      WegNr[Nr]:=True;
      If Solution Then With Cells[x,y] Do CellType:=CellType+[cSolution];
    Until WegNr[0] And WegNr[1] And WegNr[2] And WegNr[3];

    Result:=(cSolution In Cells[x,y].CellType) Or (cStart In Cells[x,y].CellType);
  End;

Var x, y: Integer;
Begin
  For x:=0 To High(Cells) Do
    For y:=0 To High(Cells[0]) Do Begin
      Cells[x,y].S:=True;
      Cells[x,y].O:=True;
      Cells[x,y].CellType:=[cFree];
    End;
  With Cells[StartX,StartY] Do CellType:=CellType+[cStart];
  // ein zufälliges Ziel
  x:=Random(High(Cells)+1); y:=High(Cells[0]);
  With Cells[x,y] Do CellType:=CellType+[cFinal];
  // Anfangszelle setzten
  NewWay(x,y,-1);
End;

procedure TForm1.CheckBox1Click(Sender: TObject);
begin
  DrawMaze(CheckBox1.Checked);
end;

End.

Die procedure NewWay habe ich rekursiv geschrieben

mfg