unit uTetris;
interface
uses
SysUtils, Classes, Contnrs, Graphics, Dialogs, Types;
type
TFigurPoints =
array[0..3]
of TPoint;
TFigurType = (ftO, ftJ, ftL, ftT, ftI, ftZ, ftS);
TFigurMove = (fmMoveLeft, fmMoveRight, fmTurnRight, fmMoveDown);
TToken =
class
private
FColor: TColor;
FX, FY: integer;
public
procedure Draw(Canvas: TCanvas; TokenSize: integer);
property Color: TColor
read FColor
write FColor;
property X: integer
read FX
write FX;
property Y: integer
read FY
write FY;
end;
TTetris =
class(TObjectList)
private
FBitmap: TBitmap;
FColCount, FRowCount, FLevel, FScore, FTokenSize: integer;
function GetToken(
Index: integer): TToken;
function TokenAdd(Color: TColor; X, Y: integer): TToken;
function MoveCurrent(FigurMove: TFigurMove; Applying: boolean): boolean;
function GetCurrentCenterPoint: TPoint;
function CanMoveCurrent(
const P: TFigurPoints): boolean;
function CanSetCurrent(
const P: TFigurPoints): boolean;
function GetCurrent: TFigurPoints;
procedure SetCurrent(
const Value: TFigurPoints);
procedure DelLine(Row: integer);
property FToken[
Index: integer]: TToken
read GetToken;
property FCurrent: TFigurPoints
read GetCurrent
write SetCurrent;
public
procedure AddNewCurrent;
function CurrentMoveDown: boolean;
function CurrentMoveLeft: boolean;
function CurrentMoveRight: boolean;
function CurrentTurnRight: boolean;
procedure CurrentFallDown;
procedure Draw;
procedure DelLines;
function GameOver: boolean;
constructor Create;
destructor Destroy;
override;
property Score: integer
read FScore
write FScore;
property TokenSize: integer
read FTokenSize
write FTokenSize;
property ColCount: integer
read FColCount
write FColCount;
property RowCount: integer
read FRowCount
write FRowCount;
property Level: integer
read FLevel
write FLevel;
property Bitmap: TBitmap
read FBitmap;
end;
implementation
{ TToken }
procedure TToken.Draw(Canvas: TCanvas; TokenSize: integer);
var
X1, X2, X3, Y1, Y2, Y3: integer;
begin
X1 := FX * TokenSize;
Y1 := FY * TokenSize;
X2 := X1 + TokenSize;
Y2 := Y1 + TokenSize;
X3 := TokenSize
div 4;
Y3 := X3;
Canvas.Brush.Color := FColor;
Canvas.Pen.Color := clBlack;
Canvas.RoundRect(X1, Y1, X2, Y2, X3, Y3);
end;
{ TTetris }
function TTetris.GetToken(
Index: integer): TToken;
begin
Result := TToken(Items[
Index]);
end;
function TTetris.GetCurrent: TFigurPoints;
var
J: integer;
begin
for J := 1
to 4
do
begin
Result[J - 1].X := FToken[Count - J].X;
Result[J - 1].Y := FToken[Count - J].Y;
end;
end;
procedure TTetris.SetCurrent(
const Value: TFigurPoints);
var
J: integer;
begin
for J := 1
to 4
do
begin
FToken[Count - J].X := Value[J - 1].X;
FToken[Count - J].Y := Value[J - 1].Y;
end;
end;
procedure TTetris.AddNewCurrent;
const
FigurTypeCount = 7;
clOrange = $000080FF;
var
Left: integer;
FigurType: TFigurType;
begin
Left := Random(FColCount - 3);
FigurType := TFigurType(Random(FigurTypeCount));
case FigurType
of
ftO:
begin
TokenAdd(clYellow, Left, 0);
TokenAdd(clYellow, Left + 1, 0);
TokenAdd(clYellow, Left, 1);
TokenAdd(clYellow, Left + 1, 1);
end;
ftJ:
begin
TokenAdd(clBlue, Left + 1, 2);
TokenAdd(clBlue, Left + 1, 1);
TokenAdd(clBlue, Left + 1, 0);
TokenAdd(clBlue, Left, 2);
end;
ftL:
begin
TokenAdd(clOrange, Left + 1, 2);
TokenAdd(clOrange, Left + 1, 1);
TokenAdd(clOrange, Left + 1, 0);
TokenAdd(clOrange, Left + 2, 2);
end;
ftT:
begin
TokenAdd(clPurple, Left + 1, 1);
TokenAdd(clPurple, Left, 0);
TokenAdd(clPurple, Left + 1, 0);
TokenAdd(clPurple, Left + 2, 0);
end;
ftI:
begin
TokenAdd(clAqua, Left, 0);
TokenAdd(clAqua, Left, 1);
TokenAdd(clAqua, Left, 2);
TokenAdd(clAqua, Left, 3);
end;
ftZ:
begin
TokenAdd(clRed, Left + 1, 1);
TokenAdd(clRed, Left + 2, 1);
TokenAdd(clRed, Left + 1, 0);
TokenAdd(clRed, Left, 0);
end;
ftS:
begin
TokenAdd(clGreen, Left, 1);
TokenAdd(clGreen, Left + 1, 1);
TokenAdd(clGreen, Left + 1, 0);
TokenAdd(clGreen, Left + 2, 0);
end;
end;
Draw;
end;
function TTetris.GetCurrentCenterPoint: TPoint;
var
J: integer;
P: TFigurPoints;
begin
Result.X := 0;
Result.Y := 0;
P := FCurrent;
for J := 0
to 3
do
begin
Result.X := Result.X + P[J].X;
Result.Y := Result.Y + P[J].Y;
end;
Result.X := Round(Result.X / 4);
Result.Y := Round(Result.Y / 4);
end;
function TTetris.CanMoveCurrent(
const P: TFigurPoints): boolean;
var
I, J: integer;
begin
Result := true;
for I := 0
to Count - 5
do
for J := 0
to 3
do
if (P[J].X = FToken[I].X)
and (P[J].Y = FToken[I].Y)
then
Result := false;
end;
function TTetris.CanSetCurrent(
const P: TFigurPoints): boolean;
var
J: integer;
begin
Result := true;
for J := 0
to 3
do
if (P[J].X < 0)
or (P[J].X >= FColCount)
or (P[J].Y < 0)
or (P[J].Y >= FRowCount)
then
Result := false;
Result := Result
and CanMoveCurrent(P);
end;
function TTetris.MoveCurrent(FigurMove: TFigurMove; Applying: boolean): boolean;
var
J: integer;
ACurrentCenterPoint: TPoint;
ACurrent, ACurrentCenter: TFigurPoints;
begin
Result := false;
ACurrent := FCurrent;
case FigurMove
of
fmMoveLeft:
for J := 0
to 3
do
Dec(ACurrent[J].X);
fmMoveRight:
for J := 0
to 3
do
Inc(ACurrent[J].X);
fmMoveDown:
for J := 0
to 3
do
Inc(ACurrent[J].Y);
fmTurnRight:
begin
ACurrentCenterPoint := GetCurrentCenterPoint;
for J := 0
to 3
do
begin
ACurrentCenter[J].X := ACurrent[J].X - ACurrentCenterPoint.X;
ACurrentCenter[J].Y := ACurrent[J].Y - ACurrentCenterPoint.Y;
end;
for J := 0
to 3
do
begin
ACurrent[J].X := -ACurrentCenter[J].Y + ACurrentCenterPoint.X;
ACurrent[J].Y := ACurrentCenter[J].X + ACurrentCenterPoint.Y;
end;
end;
end;
if CanSetCurrent(ACurrent)
then
begin
Result := true;
if Applying
then
FCurrent := ACurrent;
end;
end;
function TTetris.CurrentMoveDown: boolean;
begin
Result := MoveCurrent(fmMoveDown, true);
end;
function TTetris.CurrentMoveLeft: boolean;
begin
Result := MoveCurrent(fmMoveLeft, true);
end;
function TTetris.CurrentMoveRight: boolean;
begin
Result := MoveCurrent(fmMoveRight, true);
end;
function TTetris.CurrentTurnRight: boolean;
begin
Result := MoveCurrent(fmTurnRight, true);
end;
procedure TTetris.CurrentFallDown;
begin
while CurrentMoveDown
do
Inc(FScore);
end;
function TTetris.GameOver: boolean;
begin
Result :=
not MoveCurrent(fmMoveDown, false)
and not MoveCurrent(fmMoveLeft, false)
and not MoveCurrent(fmMoveRight, false)
and not MoveCurrent(fmTurnRight, false);
end;
procedure TTetris.DelLine(Row: integer);
var
I: integer;
begin
for I := Count - 1
downto 0
do
if FToken[I].Y = Row
then
Delete(I);
for I := 0
to Count - 1
do
if FToken[I].Y < Row
then
FToken[I].Y := FToken[I].Y + 1;
end;
procedure TTetris.DelLines;
var
Row, Col, I, N, Rows: integer;
begin
Row := FRowCount - 1;
Rows := 0;
while Row > 0
do
begin
N := 0;
for Col := 0
to FColCount - 1
do
for I := 0
to Count - 1
do
if (FToken[I].X = Col)
and (FToken[I].Y = Row)
then
Inc(N);
if N = FColCount
then
begin
DelLine(Row);
Inc(Row);
Inc(Rows);
end;
Dec(Row);
end;
case Rows
of
1: Inc(FSCore, FLevel * 40);
2: Inc(FSCore, FLevel * 100);
3: Inc(FSCore, FLevel * 300);
4: Inc(FSCore, FLevel * 1200);
end;
end;
procedure TTetris.Draw;
var
I: integer;
begin
FBitmap.Canvas.Brush.Color := clCream;
FBitmap.Canvas.FillRect(Rect(0, 0, FBitmap.Width, FBitmap.Height));
FBitmap.Canvas.Pen.Color := clSilver;
for I := 1
to FColCount
do
begin
FBitmap.Canvas.MoveTo(I * FTokenSize, 0);
FBitmap.Canvas.LineTo(I * FTokenSize, FRowCount * FTokenSize);
end;
for I := 1
to FRowCount
do
begin
FBitmap.Canvas.MoveTo(0, I * FTokenSize);
FBitmap.Canvas.LineTo(FColCount * FTokenSize, I * FTokenSize);
end;
for I := 0
to Count - 1
do
FToken[I].Draw(FBitmap.Canvas, FTokenSize);
end;
function TTetris.TokenAdd(Color: TColor; X, Y: integer): TToken;
begin
Result := TToken.Create;
Result.Color := Color;
Result.X := X;
Result.Y := Y;
Add(Result);
end;
constructor TTetris.Create;
begin
inherited Create(true);
FBitmap := TBitmap.Create;
end;
destructor TTetris.Destroy;
begin
FBitmap.Free;
inherited Destroy;
end;
end.