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)
|