шота молчать все, как рыбы об танк.... ладно, продолжим из любви к исскуству.
модуль TetrisGameClass:
unit TetrisGameClass;
interface
uses
Classes, Graphics, SysUtils, Types, StdCtrls, Grids, GameGridClass, ExtCtrls;
const
clFixed = clBtnFace;
clEmpty = clWhite;
clFigure = clBlue;
clDropped = clGreen;
type
TTetrisGame = class (TGameGrid)
private
procedure Freeze;
procedure NewFigure;
function CheckSpace (dx, dy: integer): boolean;
procedure CheckState;
protected
procedure DeleteRow (ARow: integer); override;
public
constructor Create (AComponent: TComponent); override;
procedure DrawCell (ACol, ARow: integer;
ARect: TRect; AState: TGridDrawState); override;
procedure FigureLeft;
procedure FigureRight;
procedure Move; override;
procedure MoveFigure (dx, dy: integer);
procedure Prepare; override;
end;
implementation
{ TTetrisGame }
function TTetrisGame.CheckSpace(dx, dy: integer): boolean;
var
i, j: integer;
begin
Result := TRUE;
for j := RowCount - dy - 1 downto 0 do begin
for i := 1 to ColCount - 2 do begin
if Cells [i, j] = '1' then begin
if (Cells [i + dx, j + dy] = '0') or
(Cells [i + dx, j + dy] = '2') then
Result := FALSE;
end;
end;
end;
end;
procedure TTetrisGame.CheckState;
var
i, j: integer;
AGameOver,
AFilledRow: boolean;
begin
j := RowCount - 2;
while j >= 0 do begin
AFilledRow := TRUE;
for i := 1 to ColCount - 2 do
if Cells [i, j] <> '2' then
AFilledRow := FALSE;
if AFilledRow then
DeleteRow (j)
else
Dec (j);
end;
AGameOver := FALSE;
for j := RowCount - 1 downto 0 do
for i := 1 to ColCount - 2 do
if (Cells [i, j] = '2') and (j < 4) then
AGameOver := TRUE;
if AGameOver then
State := gsUserLoose;
end;
constructor TTetrisGame.Create(AComponent: TComponent);
begin
inherited;
FixedCols := 0;
FixedRows := 0;
ColCount := 11;
RowCount := 21;
DefaultColWidth := 16;
DefaultRowHeight := 16;
DefaultDrawing := FALSE;
GridLineWidth := 0;
ScrollBars := ssNone;
Options := [];
Width := (DefaultColWidth + GridLineWidth) * ColCount + 4;
Height := (DefaultRowHeight + GridLineWidth) * RowCount + 4;
Randomize;
end;
procedure TTetrisGame.DeleteRow(ARow: integer);
var
i, j: integer;
begin
for j := ARow downto 1 do
for i := 1 to ColCount - 2 do
Cells [i, j] := Cells [i, j - 1];
for i := 1 to ColCount - 2 do
Cells [i, 0] := '';
end;
procedure TTetrisGame.DrawCell(ACol, ARow: integer; ARect: TRect;
AState: TGridDrawState);
var
AValue: integer;
begin
inherited;
with Canvas do begin
if Cells [ACol, ARow] <> '' then begin
AValue := StrToInt (Cells [ACol, ARow]);
case AValue of
0: begin
Brush.Color := clFixed;
FillRect (ARect);
Frame3D (Canvas, ARect, clWhite, clGray, 1);
end;
1: begin
Brush.Color := clFigure;
FillRect (ARect);
Frame3D (Canvas, ARect, clAqua, clNavy, 1);
end;
2: begin
Brush.Color := clDropped;
FillRect (ARect);
Frame3D (Canvas, ARect, clLime, clTeal, 1);
end;
end;
end else begin
Brush.Color := clEmpty;
FillRect (ARect);
end;
end;
end;
procedure TTetrisGame.FigureLeft;
begin
if CheckSpace (-1, 0) then
MoveFigure (-1, 0);
end;
procedure TTetrisGame.FigureRight;
begin
if CheckSpace (1, 0) then
MoveFigure (1, 0);
end;
procedure TTetrisGame.Freeze;
var
i, j: integer;
begin
for j := 0 to RowCount - 1 do
for i := 1 to ColCount - 2 do
if Cells [i, j] = '1' then
Cells [i, j] := '2';
end;
procedure TTetrisGame.Move;
begin
if CheckSpace (0, 1) then
MoveFigure (0, 1)
else begin
Freeze;
CheckState;
if State = gsPlaying then
NewFigure;
end;
end;
procedure TTetrisGame.MoveFigure(dx, dy: integer);
var
i, j: integer;
begin
for j := RowCount - 2 downto 0 do
if dx < 0 then begin
for i := 1 to ColCount - 2 do
if Cells [i, j] = '1' then
if Cells [i + dx, j + dy] = '' then begin
Cells [i + dx, j + dy] := Cells [i, j];
Cells [i, j] := '';
end;
end else begin
for i := ColCount - 2 downto 1 do
if Cells [i, j] = '1' then
if Cells [i + dx, j + dy] = '' then begin
Cells [i + dx, j + dy] := Cells [i, j];
Cells [i, j] := '';
end;
end;
end;
procedure TTetrisGame.NewFigure;
var
AFigure,
ARotation,
fLeft,
fTop: integer;
begin
AFigure := Random (8);
ARotation := Random (4);
fLeft := ColCount div 2 - 2;
fTop := 0;
case AFigure of
0, 5..7: begin
Cells [fLeft + 2, fTop] := '1';
Cells [fLeft + 2, fTop + 1] := '1';
Cells [fLeft + 2, fTop + 2] := '1';
Cells [fLeft + 2, fTop + 3] := '1';
end;
1: begin
Cells [fLeft + 1, fTop] := '1';
Cells [fLeft + 2, fTop] := '1';
Cells [fLeft + 1, fTop + 1] := '1';
Cells [fLeft + 2, fTop + 1] := '1';
end;
2: begin
Cells [fLeft + 1, fTop] := '1';
Cells [fLeft + 2, fTop] := '1';
Cells [fLeft + 2, fTop + 1] := '1';
Cells [fLeft + 3, fTop + 1] := '1';
end;
3: begin
Cells [fLeft + 2, fTop] := '1';
Cells [fLeft + 3, fTop] := '1';
Cells [fLeft + 1, fTop + 1] := '1';
Cells [fLeft + 2, fTop + 1] := '1';
end;
4: begin
Cells [fLeft + 1, fTop] := '1';
Cells [fLeft + 2, fTop] := '1';
Cells [fLeft + 3, fTop] := '1';
Cells [fLeft + 2, fTop + 1] := '1';
end;
end;
end;
procedure TTetrisGame.Prepare;
var
i, j: integer;
begin
for i := 1 to ColCount - 2 do
for j := 0 to RowCount - 2 do
Cells [i, j] := '';
for i := 0 to RowCount - 1 do begin
Cells [0, i] := '0';
Cells [ColCount - 1, i] := '0';
end;
for i := 1 to ColCount - 2 do
Cells [i, RowCount - 1] := '0';
NewFigure;
end;
end.
куча недоделок. например, генерится только 4 фигуры вместо 7 (лениво дописывать однотипные вещи), фигуры не умеют переворачиваться и "падать" вниз до конца по нажатию кнопки, не увеличивается скорость, ну и ещё парочка мелочей. но в целом фигуры генерятся, падают, двигаются вправо/влево, и при заполнении ряда он стирается. о, ещё подсчёт очков тоже лень писать.
сама программа выглядит так:
unit UnitMain;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, GameGridClass, TetrisGameClass, StdCtrls;
type
TFormMain = class(TForm)
Button1: TButton;
Button2: TButton;
Button3: TButton;
Button4: TButton;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure Button2Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure Button4Click(Sender: TObject);
private
{ Private declarations }
fTetris: TTetrisGame;
public
{ Public declarations }
end;
var
FormMain: TFormMain;
implementation
{$R *.dfm}
procedure TFormMain.FormCreate(Sender: TObject);
begin
fTetris := TTetrisGame.Create (Self);
fTetris.Parent := Self;
fTetris.Speed := 500;
fTetris.Prepare;
end;
procedure TFormMain.Button1Click(Sender: TObject);
begin
if fTetris.State <> gsPaused then
fTetris.Prepare;
fTetris.Play;
end;
procedure TFormMain.FormClose(Sender: TObject; var Action: TCloseAction);
begin
fTetris.Stop;
Action := caFree;
end;
procedure TFormMain.Button2Click(Sender: TObject);
begin
fTetris.Pause;
end;
procedure TFormMain.Button3Click(Sender: TObject);
begin
fTetris.FigureLeft;
end;
procedure TFormMain.Button4Click(Sender: TObject);
begin
fTetris.FigureRight;
end;
end.
будет нечего делать - допишу остальное.