Home> Pascal> Tetris
Tetris
Vorwort
Nachfolgend finden Sie den Kern eines Tetris-Spiels. Das Programm enthält nur die grundelegenden Funktionen für das Bewegen/Drehen eines Steines und Löschen voller Reihen. Punktewerung, Geschwindigkeitssteigerung u.ä. sind nicht vorhanden und bleiben Ihnen überlassen. Ein Beispiel für einen vollständigen Tetris-Klon finden Sie im Software-Bereich
Aufgrund der Länge des Programms sind die Kommentare diesmal direkt unterhalb des entsprechenden Codes. In diesem Programm werden sehr häufig Koordinaten verwendet, beachten Sie deshalb bitte, dass bei Pascal der y-Wert nach unten zunimmt.
Download
Code
program Tetris;
uses crt, graph, windos;
const cols = 15; rows = 30;
      FieldX = 50; FieldY = 50;
      Size = 12;
cols gibt die Zahl der Spalten des Spielfelds an, rows die der Reihen. FieldX und FieldY bestimmen die linke obere Ecke des Spielfelds, size die Größe eines Steins.
type FieldType = array[1..cols ,1..rows] of byte;
     BlockType = array[-2..2, -2..2] of boolean;
     LineType = array[1..rows] of boolean;
var  Field : FieldType;
     Block, BlockTEMP : BlockType;
     BlockX, BlockY, BlockC, BlockNbr : byte;
     Ende, NoDown : boolean;
     Taste : char;
Field enthält für jeden Stein im Spielfeld die Farbe, bei 0 ist kein Stein vorhanden.
Block bestimmt das Aussehen des aktuellen Blocks. Da die Farbe einheitlich ist, muss nur unterschieden werden ob an einer Position ein Stein vorhanden ist oder nich.
BlockTEMP ist ein Zwischenspeicher für das Drehen des Blockes. BlockX, BlockY enthalten die Koordinaten des aktuellen Blocks; BlockC seine Farbe und BlockNbr seinen Typ.
Ende zeigt an, ob das Programm beendet werden soll, NoDown ob der Block noch weiter fallen kann. Taste enthält die vom Benutzer gedrückte Taste.
procedure Initialize;
var Gd, Gm: Integer;
begin
  randomize;
  Gd := Detect;
  InitGraph(Gd, Gm, '');
  if GraphResult <> grOk then
    Halt(1);
end;
Der Zufallsgenerator wird initialisiert und der Graphikmodus gesetzt
function Time : real;
var h, m, s, hs : word;
begin
  GetTime(h,m,s,hs);
  Time := 3600*h + 60*m + s + hs/100;
end;
Diese Funktion gibt die aktuelle Systemzeit in Sekunden zurück.
procedure GetKey;
begin
  IF Taste <> '_' THEN Exit;
  IF keypressed THEN Taste := readkey;
end;
Diese Funktion bestimmt die aktuell gedrückte Taste, falls noch keine Eingabe erfolgte (Taste <> '_'). Um zu verhindern, dass das Programm bis zum nächsten Tastendruck angehalten wird, wird readkey nur ausgeführt wenn wirklich eine Taste gedrückt wird.
function CheckTEMP : boolean;
var correct : boolean;
    x, y : integer;
begin
  correct := true;
  for x := -2 to 2 do
   for y := -2 to 2 do
    IF   BlockTEMP[x,y]
    THEN begin
         IF Field[BlockX+x,BlockY+y] <> 0 THEN correct := false;
         IF ((BlockX+x) < 1) OR ((BlockX+x) > cols) THEN correct := false;
         IF ((BlockY+y) < 1) OR ((BlockY+y) > rows) THEN correct := false;
         end;
  CheckTEMP := correct;
end;
Diese Funktion prüft, ob der Block-Zwischenspeicher einen korrekten Block enthält. Kollidiert der Block mit einem im Feld vorhandenen Stein oder liegt teilweise außerhalb des Felds, wird false zurückgegeben.
function CheckMove(xMov, yMov : integer) : boolean;
var correct : boolean;
    x, y : integer;
begin
  correct := true;
  for x := -2 to 2 do
   for y := -2 to 2 do
    IF   Block[x,y]
    THEN begin
         IF Field[BlockX+x+xMov,BlockY+y+yMov] <> 0 THEN correct := false;
         IF ((BlockX+x+xMov) < 1) OR ((BlockX+x+xMov) > cols) THEN correct := false;
         IF ((BlockY+y+yMov) < 1) OR ((BlockY+y+yMov) > rows) THEN correct := false;
         end;
  IF (NOT correct) AND (yMov > 0) THEN NoDown := true;
  CheckMove := correct;
end;
Diese Funktion prüft analog zu CheckTEMP ob eine bestimmte Bewegung ohne Kollision oder Verlassen des Spielfelds ausgeführt werden kann.
procedure ClearField;
var x, y : integer;
begin
  for x := 1 to cols do
    for y := 1 to rows do
      Field[x,y] := 0;
end;

procedure ClearBlockTEMP;
var x, y : integer;
begin
  for x := -2 to 2 do
    for y := -2 to 2 do
      BlockTEMP[x,y] := false;
end;
Diese Funktionen löschen das Feld bezw. den Block-Zwischenspeicher.
procedure DrawBorder;
begin
  SetColor(15);
  MoveTo(FieldX-1,FieldY);
  LineTo(FieldX-1,FieldY+ size*rows);
  LineTo(FieldX +size*cols,FieldY+size*rows);
  LineTo(FieldX +size*cols,FieldY);
end;
Zeichnet den Rand des Spielfelds.
procedure DrawField;
var x, y : integer;
begin
  SetFillStyle(SolidFill,0);
  Bar(FieldX,FieldY,FieldX+cols*size,FieldY+rows*size);
  DrawBorder;
  for x := 1 to cols do
   for y := 1 to rows do
    IF   Field[x,y] <> 0
    THEN begin
         SetFillStyle(SolidFill, Field[x,y]);
         Bar(FieldX+(x-1)*size,FieldY+(y-1)*size,FieldX+x*size-1,FieldY+y*size-1);
         end;
end;
Zeichnet das Spielfeld komplett neu.
procedure AddBlockToField;
var x, y : integer;
begin
  for x := -2 to 2 do
    for y := -2 to 2 do
      IF Block[x,y] THEN Field[BlockX+x,BlockY+y] := BlockC;
end;
"Verschmilzt" den Block mit dem Spielfeld
procedure NewBlock;
var x, y : integer;
begin
  for x := -2 to 2 do
    for y := -2 to 2 do
      Block[x,y] := false;
  BlockNbr := Random(8);
  case BlockNbr of
    0 : for x := -2 to 2 do Block[x,0] := true; {#####}
    1 : for x := -1 to 2 do Block[x,0] := true; { ####}
    2..4 : begin
           for x := -1 to 1 do Block[x,0] := true;   { ### }
           Block[BlockNbr-3,1] := true;              { 234 }
           end;
    5 : for x := 0 to 1 do                      {  ## }
          for y := 0 to 1 do                    {  ## }
            Block[x,y] := true;
    6 : for x := -1 to 0 do                     { ##  }
          for y := 0 to 1 do                    {  ## }
            Block[x+y,y] := true;
    7 : for x := 0 to 1 do                      {  ## }
          for y := 0 to 1 do                    { ##  }
            Block[x-y,y] := true;
  end;
  BlockC := Random(14) + 1;
  BlockX := (cols+1) div 2;
  BlockY := 1;
  IF NOT CheckMove(0,0) THEN Ende := true;
end;
Erzeugt zufällig einen neuen Block. Sollte dieser nicht ins Spielfeld passen (NOT CheckMove(0,0)) wird das Spiel beendet.
procedure DrawBlock(c : byte);
var x, y, x1, x2, y1, y2 : integer;
begin
  SetFillStyle(SolidFill,c);
  for x := -2 to 2 do
   for y := -2 to 2 do
    IF   Block[x,y]
    THEN begin
         x1 := (BlockX+x-1)*Size + FieldX;
         x2 := x1 + Size - 1;
         y1 := (BlockY+y-1)*Size + FieldY;
         y2 := y1 + Size - 1;
         Bar(x1,y1, x2,y2);
         end;
end;
Zeichnet den aktuellen Block in der angegebenen Farbe.
procedure MoveBlock(xMov, yMov : integer);
begin
  IF   CheckMove(xMov, yMov)
  THEN begin
       DrawBlock(0);
       BlockX := BlockX + xMov;
       BlockY := BlockY + yMov;
       DrawBlock(BlockC);
       end;
end;
Prüft zunächst ob die Bewegung ausführbar ist. Wenn ja wird zunächst der Block gelöscht (schwarz überzeichnet), dann bewegt und zuletzt neu gezeichnet.
procedure RotateBlock;
var x, y, xT, yT : integer;
begin
  IF BlockNbr = 5 THEN Exit; {Quadrat}
  ClearBlockTEMP;
  IF   BlockNbr = 1 {####}
  THEN begin
       IF Block[0,1] {senkrecht} THEN
        for x := -1 to 2 do BlockTEMP[x,0] := true
       ELSE for y := -1 to 2 do BlockTEMP[0,y] := true;
       end;
  for x := -2 to 2 do
   for y := -2 to 2 do
    begin
      xT := y*-1; yT := x;
      BlockTEMP[xT,yT] := Block[x,y];
    end;
  IF   CheckTEMP
  THEN begin
       DrawBlock(0);
       for x := -2 to 2 do
        for y := -2 to 2 do
         Block[x,y] := BlockTEMP[x,y];
       DrawBlock(BlockC);
       end;
end;
Dreht den Block um 90° um den Stein in der Mitte. Für die zwei Steine (4x1, 2x2) deren Mittelpunkt zwischen den Steinen liegt gelten Sonderregeln. 2x2 (Nummer 5) wird überhaupt nicht gedreht, für 4x1 (Nummer 1) gilt die Regel in der THEN-Anweisung.
procedure DeleteLine(Nbr : integer);
var x, y : integer;
begin
  IF   Nbr > 1
  THEN begin
       for y := Nbr downto 2 do
        for x := 1 to cols do
         Field[x,y] := Field[x,y-1];
        end;
  for x := 1 to cols do
   Field[x,1] := 0;
end;
Löscht die angegeben Linie und verschiebt die darüberliegenden nach unten.
procedure ClearLines;
var i, x, y : integer;
    LTC : LineType;
    full, continue : boolean;
begin
  continue := false;
  for y := 1 to rows do
   begin
    GetKey;
    full := true;
    for x := 1 to cols do
     IF Field[x,y] = 0 THEN full := false;
     LTC[y] := full; IF full THEN continue := true;
   end;
Es wird zunächst festgestellt, welche Reihen voll sind. Ist min. 1 Reihe gefüllt, wird continue auf wahr gesetzt, um anzuzeigen das fortzufahren ist.
Um zu verhindern, dass eine Taste, die während des Ablaufs (der auf manchen Computer relativ zeitintensiven) Prozedur gedrückt und vor ihrem Ende wieder losgelassen wird, werden zwischendurch GetKey-Abfragen durchgeführt.
  IF NOT continue THEN Exit;
  for i := 1 to 4 do
  begin
   for y := 1 to rows do
    IF   LTC[y]
    THEN begin
         IF i mod 1 = 1 THEN SetFillStyle(SolidFill,15) ELSE SetFillStyle(SolidFill,0);
         Bar(FieldX,FieldY+(y-1)*size,FieldX+cols*size,FieldY+y*size);
         end;
  Delay(300);
  end;
Die gefüllten Reihen blinken zunächst ...
  for y := 1 to rows do
    IF LTC[y] THEN DeleteLine(y);
  DrawField;
end;
... und werden anschließend gelöscht.
procedure Main;
var LastCycle, Speed : real;
    Drop : boolean;
LastCycle gibt den Zeitpunkt des letzten "Computer-Zugs" (Block eins nach unten, Überprüfung auf volle Reihen) an. Speedbestimmt die Zeit zwischen zwei Computer-Zügen. Dropgibt an, ob der Block fallengelassen wird.
begin
  Ende := false; Taste := '_'; Speed := 0.5;
  ClearDevice; ClearField; DrawBorder; NewBlock;
Vorbereitungen vor dem Spiel.
  repeat
   LastCycle := Time;
   repeat
    Drop := false;
    GetKey;
    case Taste of
      'a', 'j' : MoveBlock(-1,0);
      'd', 'l' : MoveBlock(1,0);
      's', 'k' : Drop := true;
      'w', 'i' : RotateBlock;
      'q' : Ende := true;
    end;
    Taste := '_';
Abhängig von der gedrückten Taste wird eine Aktion ausgeführt, Taste wird danach auf den Standardwert('_') zurückgesetzt.
   until (Time >= LastCycle + Speed) OR Drop;
   repeat
     NoDown := false;
     MoveBlock(0,1);
     IF   NoDown
     THEN begin
          AddBlockToField;
          NewBlock;
          Drop := false;
          end;
   until NOT Drop;
   ClearLines;
Der Block wird eins nach unten verschoben, beim Fallenlassen (Drop) solange bis er anstösst (NoDown).
Anschließend wird auf volle Reihen geprüft.
  until Ende;
end;
Der Vorgang wird bis zum Ende des Spiels fortgesetzt.
begin
  Initialize;
  Main;
end.
Initialiseren; starten der Hauptprozedur (Main)

Impressum