A
Adnil
Unregistered / Unconfirmed
GUEST, unregistred user!
pas文件：
unit Unit1;
interface
uses Windows, Graphics, Forms, Buttons, ShellAPI,StdCtrls, ExtCtrls,Controls, Classes, SysUtils;
const
GlassWidth=10;
GlassHeight=23;
var
GlassWorkSheet: array [1..GlassHeight,1..GlassWidth] of Byte;
OldGlassWorkSheet: array [1..GlassHeight,1..GlassWidth] of Byte;
type
TFigureWorksheet=array [1..4,1..4] of Byte;
const
Triada: TFigureWorksheet=
((0,1,0,0),
(1,1,1,0),
(0,0,0,0),
(0,0,0,0));
LCorner: TFigureWorksheet=
((1,1,1,0),
(1,0,0,0),
(0,0,0,0),
(0,0,0,0));
RCorner: TFigureWorksheet=
((1,1,1,0),
(0,0,1,0),
(0,0,0,0),
(0,0,0,0));
LZigzag: TFigureWorksheet=
((1,1,0,0),
(0,1,1,0),
(0,0,0,0),
(0,0,0,0));
RZigzag: TFigureWorksheet=
((0,1,1,0),
(1,1,0,0),
(0,0,0,0),
(0,0,0,0));
Stick: TFigureWorksheet=
((1,1,1,1),
(0,0,0,0),
(0,0,0,0),
(0,0,0,0));
Box: TFigureWorksheet=
((1,1,0,0),
(1,1,0,0),
(0,0,0,0),
(0,0,0,0));
Add1: TFigureWorksheet=
((1,0,0,0),
(1,1,1,1),
(0,0,0,0),
(0,0,0,0));
Add2: TFigureWorksheet=
((0,0,0,1),
(1,1,1,1),
(0,0,0,0),
(0,0,0,0));
var
FigureWorkSheet: TFigureWorksheet=
((0,0,0,0),
(0,0,0,0),
(0,0,0,0),
(0,0,0,0));
const
BarWidth= 14;
BarHeight=14;
NextBarWidth= 9;
NextBarHeight=9;
TopOfs= 6;
LeftOfs= 5;
FieldWidth=4;
MaxFigureNumber=9;
MaxCornerNumber=4;
MaxFigureSize= 4;
MaxFigureColor= 7;
type
TMoveDirect= (mdDown,mdLeft,mdRight);
TFigureCorner=(fc00,fc90,fc180,fc270);
type
TForm1 = class(TForm)
Timer: TTimer;
Label1: TLabel;
Label2: TLabel;
lblLevel: TLabel;
lblCount: TLabel;
BevelT: TBevel;
Label3: TLabel;
Button1: TButton;
procedure FormCreate(Sender: TObject);
procedure OpenGame;
procedure FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure FormPaint(Sender: TObject);
procedure TimerTimer(Sender: TObject);
procedure LblStartClick(Sender: TObject);
procedure Button1Click(Sender: TObject);
public
Level: Byte;
Score: Longint;
ReentTimer: Boolean;
ReentKeys: Boolean;
FigureActive: Boolean;
FigureType: Byte;
FigureX: Byte;
FigureY: Byte;
FigureCorner: TFigureCorner;
FigureMove: TMoveDirect;
FirstColor: Byte;
SecondColor: Byte;
FirstFigure: Byte;
SecondFigure: Byte;
NextTopOfs: Integer;
NextLeftOfs: Integer;
RedrawSheet: Boolean;
function FigureXSize: Byte;
function FigureYSize: Byte;
procedure GenerateNewFigure;
procedure ClearFigureIntoGlass;
function PutFigureIntoGlass(MoveDirect: TMoveDirect): Boolean;
procedure RotateFigure;
procedure ScanFillLines;
procedure SetFigureColor;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormPaint(Sender: TObject);
var
X1,Y1,X2,Y2: Integer;
NewRect: TRect;
I,J: Byte;
CurSheet: TFigureWorksheet;
NextColor: TColor;
begin
if RedrawSheet then FillChar(OldGlassWorkSheet,SizeOf(OldGlassWorkSheet),#255);
for I := 1 to GlassHeight do
for J := 1 to GlassWidth do begin
if GlassWorkSheet[I,J]=OldGlassWorkSheet[I,J] then Continue;
X1 := LeftOfs+(J-1)*BarWidth;
X2 := X1+BarWidth;
Y1 := TopOfs+(I-1)*BarHeight;
Y2 := Y1+BarHeight;
case GlassWorkSheet[I,J] of
0: Canvas.Brush.Color := clNavy;
1: Canvas.Brush.Color := clSilver;
2: Canvas.Brush.Color := clRed;
3: Canvas.Brush.Color := clLime;
4: Canvas.Brush.Color := clBlue;
5: Canvas.Brush.Color := clFuchsia;
6: Canvas.Brush.Color := clAqua;
7: Canvas.Brush.Color := clYellow;
8: Canvas.Brush.Color := clWhite;
end;
if GlassWorkSheet[I,J]>0 then begin
NewRect := Rect(X1+1,Y1+1,X2-1,Y2-1);
Canvas.FillRect(NewRect);
Canvas.Pen.Color := clGray;
Canvas.MoveTo(X1,Y1);
Canvas.LineTo(X1,Y2-1);
Canvas.LineTo(X2-1,Y2-1);
Canvas.Pen.Color := clWhite;
Canvas.LineTo(X2-1,Y1);
Canvas.LineTo(X1,Y1);
end
else begin
NewRect := Rect(X1,Y1,X2,Y2);
Canvas.FillRect(NewRect);
end;
end;
case FirstFigure of
0: Move(Triada,CurSheet,SizeOf(CurSheet));
1: Move(LCorner,CurSheet,SizeOf(CurSheet));
2: Move(RCorner,CurSheet,SizeOf(CurSheet));
3: Move(LZigzag,CurSheet,SizeOf(CurSheet));
4: Move(RZigzag,CurSheet,SizeOf(CurSheet));
5: Move(Stick,CurSheet,SizeOf(CurSheet));
6: Move(Box,CurSheet,SizeOf(CurSheet));
7: Move(Add1,CurSheet,SizeOf(CurSheet));
8: Move(Add2,CurSheet,SizeOf(CurSheet));
end;
case FirstColor of
0: NextColor := clNavy;
1: NextColor := clSilver;
2: NextColor := clRed;
3: NextColor := clLime;
4: NextColor := clBlue;
5: NextColor := clFuchsia;
6: NextColor := clAqua;
7: NextColor := clYellow;
8: NextColor := clWhite;
end;
for I := 1 to MaxFigureSize-2 do
for J := 1 to MaxFigureSize do begin
X1 := NextLeftOfs+(J-1)*NextBarWidth;
X2 := X1+NextBarWidth;
Y1 := NextTopOfs+(I-1)*NextBarHeight;
Y2 := Y1+NextBarHeight;
if CurSheet[I,J]>0 then begin
NewRect := Rect(X1+1,Y1+1,X2-1,Y2-1);
Canvas.Brush.Color := NextColor;
Canvas.FillRect(NewRect);
Canvas.Pen.Color := clGray;
Canvas.MoveTo(X1,Y1);
Canvas.LineTo(X1,Y2-1);
Canvas.LineTo(X2-1,Y2-1);
Canvas.Pen.Color := clWhite;
Canvas.LineTo(X2-1,Y1);
Canvas.LineTo(X1,Y1);
end
else begin
Canvas.Brush.Color := clSilver;
NewRect := Rect(X1,Y1,X2,Y2);
Canvas.FillRect(NewRect);
end;
end;
Move(GlassWorkSheet,OldGlassWorkSheet,SizeOf(OldGlassWorkSheet));
end;
function TForm1.FigureXSize: Byte;
var
I,J,K: Byte;
begin
K := 0;
for J := 1 to MaxFigureSize do
for I := 1 to MaxFigureSize do
if FigureWorkSheet[J,I]>0 then
if K<I then K := I;
FigureXSize := K;
end;
function TForm1.FigureYSize: Byte;
var
I,J,K: Byte;
begin
K := 0;
for J := 1 to MaxFigureSize do
for I := 1 to MaxFigureSize do
if FigureWorkSheet[J,I]>0 then
if K<J then K := J;
FigureYSize := K;
end;
procedure TForm1.GenerateNewFigure;
begin
Timer.Enabled := False;
SecondFigure := FirstFigure;
SecondColor := FirstColor;
FigureType := SecondFigure;
FigureX := 5;
FigureY := 0;
FigureCorner := fc270;
FillChar(FigureWorkSheet,SizeOf(FigureWorkSheet),0);
case FigureType of
0: Move(Triada,FigureWorkSheet,SizeOf(FigureWorkSheet));
1: Move(LCorner,FigureWorkSheet,SizeOf(FigureWorkSheet));
2: Move(RCorner,FigureWorkSheet,SizeOf(FigureWorkSheet));
3: Move(LZigzag,FigureWorkSheet,SizeOf(FigureWorkSheet));
4: Move(RZigzag,FigureWorkSheet,SizeOf(FigureWorkSheet));
5: Move(Stick,FigureWorkSheet,SizeOf(FigureWorkSheet));
6: Move(Box,FigureWorkSheet,SizeOf(FigureWorkSheet));
7: Move(Add1,FigureWorkSheet,SizeOf(FigureWorkSheet));
8: Move(Add1,FigureWorkSheet,SizeOf(FigureWorkSheet));
end;
SetFigureColor;
FigureMove := mdDown;
FirstFigure := Random(MaxFigureNumber);
FirstColor := Random(MaxFigureColor)+1;
Timer.Enabled := True;
end;
procedure TForm1.ClearFigureIntoGlass;
var
I,J: Byte;
begin
for J := 1 to FigureYSize do
for I := 1 to FigureXSize do
if FigureWorkSheet[J,I]>0 then
GlassWorkSheet[FigureY+J,FigureX+I] := 0;
end;
function TForm1.PutFigureIntoGlass(MoveDirect: TMoveDirect): Boolean;
var
I,J: Byte;
begin
PutFigureIntoGlass := True;
if (FigureY+FigureYSize>GlassHeight) and (MoveDirect=mdDown) then begin
Dec(FigureY);
PutFigureIntoGlass := False;
Exit;
end
else
while (FigureX+FigureXSize>GlassWidth) and (MoveDirect=mdDown) do
Dec(FigureX);
for J := 1 to FigureYSize do begin
for I := 1 to FigureXSize do begin
if (FigureWorkSheet[J,I]>0) and
(GlassWorkSheet[FigureY+J,FigureX+I]>0) then begin
PutFigureIntoGlass := False;
case MoveDirect of
mdDown: Dec(FigureY);
mdRight: Dec(FigureX);
mdLeft: Inc(FigureX);
end;
Exit;
end;
end;
end;
for J := 1 to FigureYSize do
for I := 1 to FigureXSize do
if FigureWorkSheet[J,I]>0 then
GlassWorkSheet[FigureY+J,FigureX+I] := FigureWorkSheet[J,I];
RedrawSheet := False;
FormPaint(Self);
RedrawSheet := True;
end;
procedure TForm1.ScanFillLines;
var
I,J,K,L: byte;
begin
ClearFigureIntoGlass;
for I := 1 to GlassHeight do begin
K := 0;
for J := 1 to GlassWidth do
if GlassWorkSheet[I,J]>0 then Inc(K);
if K=GlassWidth then begin
for L := I downto 1 do
for J := 1 to GlassWidth do
if L>1 then GlassWorkSheet[L,J] := GlassWorkSheet[L-1,J];
end;
end;
PutFigureIntoGlass(FigureMove);
end;
procedure TForm1.TimerTimer(Sender: TObject);
var
I,J: Byte;
begin
if ReentTimer then Exit
else ReentTimer := True;
if StrToInt(lblLevel.Caption)<>Level then lblLevel.Caption := IntToStr(Level);
if StrToInt(lblCount.Caption)<>Score then lblCount.Caption := IntToStr(Score);
if not FigureActive then begin
GenerateNewFigure;
if not PutFigureIntoGlass(FigureMove) then
begin
Application.MessageBox('完了！',Pchar(Application.Title),MB_ICONEXCLAMATION);
FillChar(OldGlassWorkSheet,SizeOf(OldGlassWorkSheet),#255);
Timer.Enabled := False;
ClearFigureIntoGlass;
FigureActive := False;
Level := 1;
Score := 0;
for I := 1 to GlassHeight do
for J := 1 to GlassWidth do GlassWorkSheet[I,J] := 0;
RedrawSheet := False;
FormPaint(Self);
RedrawSheet := True;
end;
FigureActive := True;
end
else begin
ClearFigureIntoGlass;
Inc(FigureY);
if not PutFigureIntoGlass(FigureMove) then begin
case FigureType of
0: Inc(Score,10);
1,2: Inc(Score,30);
3,4,7,8: Inc(Score,25);
5: Inc(Score,15);
6: Inc(Score,20);
end;
if Score>300 then Level := 2;
if Score>700 then Level := 3;
if Score>1300 then Level := 4;
if Score>2000 then Level := 5;
if Score>3000 then Level := 6;
if Score>5000 then Level := 7;
Timer.Interval := Round((7.1-Level)*100);
FigureActive := False;
end;
end;
ScanFillLines;
ReentTimer:=False;
end;
procedure TForm1.RotateFigure;
var
CurSheet: TFigureWorksheet;
OldFigureCorner: TFigureCorner;
procedure RotateFigureWorksheet;
var
VertFlag: Byte;
HorizFlag: Byte;
K,I,J: Byte;
begin
FillChar(FigureWorkSheet,SizeOf(FigureWorkSheet),0);
case FigureType of
0: Move(Triada,FigureWorkSheet,SizeOf(FigureWorkSheet));
1: Move(LCorner,FigureWorkSheet,SizeOf(FigureWorkSheet));
2: Move(RCorner,FigureWorkSheet,SizeOf(FigureWorkSheet));
3: Move(LZigzag,FigureWorkSheet,SizeOf(FigureWorkSheet));
4: Move(RZigzag,FigureWorkSheet,SizeOf(FigureWorkSheet));
5: Move(Stick,FigureWorkSheet,SizeOf(FigureWorkSheet));
6: Move(Box,FigureWorkSheet,SizeOf(FigureWorkSheet));
7: Move(Add1,FigureWorkSheet,SizeOf(FigureWorkSheet));
8: Move(Add1,FigureWorkSheet,SizeOf(FigureWorkSheet));
end;
FillChar(CurSheet,SizeOf(CurSheet),0);
for K := 0 to Byte(FigureCorner) do begin
for I := 1 to MaxFigureSize do
for J := 1 to MaxFigureSize do
CurSheet[J,I] := FigureWorkSheet[MaxFigureSize-I+1,J];
Move(CurSheet,FigureWorkSheet,SizeOf(FigureWorkSheet));
end;
SetFigureColor;
HorizFlag := 0;
while HorizFlag=0 do begin
for I := 1 to MaxFigureSize do
if FigureWorkSheet[1,I]>0 then HorizFlag := 1;
if HorizFlag=0 then begin
for J := 1 to MaxFigureSize-1 do
for I := 1 to MaxFigureSize do
FigureWorkSheet[J,I] := FigureWorkSheet[J+1,I];
for J := 1 to MaxFigureSize do
FigureWorkSheet[MaxFigureSize,J] := 0;
end;
end;
VertFlag := 0;
while VertFlag=0 do begin
for J := 1 to MaxFigureSize do
if FigureWorkSheet[J,1]>0 then VertFlag := 1;
if VertFlag=0 then begin
for J := 1 to MaxFigureSize do
for I := 1 to MaxFigureSize-1 do
FigureWorkSheet[J,I] := FigureWorkSheet[J,I+1];
for J := 1 to MaxFigureSize do
FigureWorkSheet[J,MaxFigureSize] := 0;
end;
end;
end;
begin
ClearFigureIntoGlass;
OldFigureCorner := FigureCorner;
if FigureCorner>fc00 then Dec(FigureCorner)
else FigureCorner := fc270;
RotateFigureWorksheet;
if not PutFigureIntoGlass(mdDown) then begin
FigureCorner := OldFigureCorner;
RotateFigureWorksheet;
PutFigureIntoGlass(mdDown);
end;
end;
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if ReentKeys then exit
else ReentKeys:=True;
if not FigureActive then
begin
ReentKeys:=False;
exit;
end;
case Key of
VK_UP,Ord('W'): RotateFigure;
VK_DOWN,Ord('S'),
VK_SPACE: begin
repeat
ClearFigureIntoGlass;
Inc(FigureY);
until not PutFigureIntoGlass(mdDown);
Inc(Score,5);
end;
VK_LEFT,
Ord('A'): if FigureX>0 then begin
ClearFigureIntoGlass;
Dec(FigureX);
PutFigureIntoGlass(mdLeft);
end;
VK_RIGHT,
Ord('D'): if FigureX+FigureXSize<GlassWidth then begin
ClearFigureIntoGlass;
Inc(FigureX);
PutFigureIntoGlass(mdRight);
end;
end;
ReentKeys := False;
end;
procedure TForm1.SetFigureColor;
var
I,J: Byte;
begin
for I := 1 to MaxFigureSize do
for J := 1 to MaxFigureSize do
if FigureWorkSheet[I,J]>0 then
FigureWorkSheet[I,J]:=SecondColor;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
OpenGame;
end;
procedure TForm1.OpenGame;
begin
BevelT.Visible:=True;
FillChar(OldGlassWorkSheet,SizeOf(OldGlassWorkSheet),#255);
RedrawSheet:=True;
Level:=1;
Timer.Interval:=Round((6.5-Level)*100);
Score:=0;
ReentTimer:=False;
ReentKeys:=False;
FigureActive:=False;
lblLevel.Caption:='1';
lblCount.Caption:='0';
Randomize;
FirstFigure:=Random(MaxFigureNumber);
FirstColor:=Random(MaxFigureColor)+1;
NextLeftOfs:=160;
NextTopOfs:=180;
OnKeyPress:=NIL;
OnPaint:=FormPaint;
end;
procedure TForm1.LblStartClick(Sender: TObject);
var
I,J: Byte;
begin
Timer.Enabled := False;
ClearFigureIntoGlass;
FigureActive := False;
Level:=1;
Score:=0;
for I:=1 to GlassHeight do
for J:=1 to GlassWidth do GlassWorkSheet[I,J] := 0;
RedrawSheet:=False;
FormPaint(Self);
RedrawSheet:=True;
Timer.Enabled:=True;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Timer.Enabled:=Not Timer.Enabled;
button1.Caption:='继续';
if Timer.Enabled then
button1.Caption:='暂停';
end;
end.
dfm文件：
object Form1: TForm1
Left = 358
Top = 157
HelpContext = 600
BorderStyle = bsDialog
Caption = #23567#28216#25103' - '#25913#20889#33258'Simple Tetris'
ClientHeight = 333
ClientWidth = 217
Color = clBtnFace
Font.Charset = GB2312_CHARSET
Font.Color = clWindowText
Font.Height = -12
Font.Name = #23435#20307
Font.Style = []
KeyPreview = True
OldCreateOrder = True
Position = poScreenCenter
OnCreate = FormCreate
OnKeyDown = FormKeyDown
PixelsPerInch = 96
TextHeight = 12
object Label1: TLabel
Left = 160
Top = 231
Width = 24
Height = 12
Caption = #31561#32423
end
object Label2: TLabel
Left = 160
Top = 274
Width = 24
Height = 12
Caption = #24471#20998
end
object lblLevel: TLabel
Left = 160
Top = 250
Width = 12
Height = 12
Caption = '99'
Font.Charset = GB2312_CHARSET
Font.Color = clRed
Font.Height = -12
Font.Name = #23435#20307
Font.Style = []
ParentFont = False
end
object lblCount: TLabel
Left = 160
Top = 291
Width = 30
Height = 12
Caption = '99999'
Font.Charset = GB2312_CHARSET
Font.Color = clRed
Font.Height = -12
Font.Name = #23435#20307
Font.Style = []
ParentFont = False
end
object BevelT: TBevel
Left = 3
Top = 4
Width = 145
Height = 326
Visible = False
end
object Label3: TLabel
Left = 158
Top = 152
Width = 36
Height = 12
Caption = #19979#19968#20010
end
object Button1: TButton
Left = 160
Top = 308
Width = 45
Height = 22
Caption = #24320#22987
TabOrder = 0
OnClick = Button1Click
end
object Timer: TTimer
Enabled = False
Interval = 100
OnTimer = TimerTimer
Left = 4
Top = 4
end
end
unit Unit1;
interface
uses Windows, Graphics, Forms, Buttons, ShellAPI,StdCtrls, ExtCtrls,Controls, Classes, SysUtils;
const
GlassWidth=10;
GlassHeight=23;
var
GlassWorkSheet: array [1..GlassHeight,1..GlassWidth] of Byte;
OldGlassWorkSheet: array [1..GlassHeight,1..GlassWidth] of Byte;
type
TFigureWorksheet=array [1..4,1..4] of Byte;
const
Triada: TFigureWorksheet=
((0,1,0,0),
(1,1,1,0),
(0,0,0,0),
(0,0,0,0));
LCorner: TFigureWorksheet=
((1,1,1,0),
(1,0,0,0),
(0,0,0,0),
(0,0,0,0));
RCorner: TFigureWorksheet=
((1,1,1,0),
(0,0,1,0),
(0,0,0,0),
(0,0,0,0));
LZigzag: TFigureWorksheet=
((1,1,0,0),
(0,1,1,0),
(0,0,0,0),
(0,0,0,0));
RZigzag: TFigureWorksheet=
((0,1,1,0),
(1,1,0,0),
(0,0,0,0),
(0,0,0,0));
Stick: TFigureWorksheet=
((1,1,1,1),
(0,0,0,0),
(0,0,0,0),
(0,0,0,0));
Box: TFigureWorksheet=
((1,1,0,0),
(1,1,0,0),
(0,0,0,0),
(0,0,0,0));
Add1: TFigureWorksheet=
((1,0,0,0),
(1,1,1,1),
(0,0,0,0),
(0,0,0,0));
Add2: TFigureWorksheet=
((0,0,0,1),
(1,1,1,1),
(0,0,0,0),
(0,0,0,0));
var
FigureWorkSheet: TFigureWorksheet=
((0,0,0,0),
(0,0,0,0),
(0,0,0,0),
(0,0,0,0));
const
BarWidth= 14;
BarHeight=14;
NextBarWidth= 9;
NextBarHeight=9;
TopOfs= 6;
LeftOfs= 5;
FieldWidth=4;
MaxFigureNumber=9;
MaxCornerNumber=4;
MaxFigureSize= 4;
MaxFigureColor= 7;
type
TMoveDirect= (mdDown,mdLeft,mdRight);
TFigureCorner=(fc00,fc90,fc180,fc270);
type
TForm1 = class(TForm)
Timer: TTimer;
Label1: TLabel;
Label2: TLabel;
lblLevel: TLabel;
lblCount: TLabel;
BevelT: TBevel;
Label3: TLabel;
Button1: TButton;
procedure FormCreate(Sender: TObject);
procedure OpenGame;
procedure FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure FormPaint(Sender: TObject);
procedure TimerTimer(Sender: TObject);
procedure LblStartClick(Sender: TObject);
procedure Button1Click(Sender: TObject);
public
Level: Byte;
Score: Longint;
ReentTimer: Boolean;
ReentKeys: Boolean;
FigureActive: Boolean;
FigureType: Byte;
FigureX: Byte;
FigureY: Byte;
FigureCorner: TFigureCorner;
FigureMove: TMoveDirect;
FirstColor: Byte;
SecondColor: Byte;
FirstFigure: Byte;
SecondFigure: Byte;
NextTopOfs: Integer;
NextLeftOfs: Integer;
RedrawSheet: Boolean;
function FigureXSize: Byte;
function FigureYSize: Byte;
procedure GenerateNewFigure;
procedure ClearFigureIntoGlass;
function PutFigureIntoGlass(MoveDirect: TMoveDirect): Boolean;
procedure RotateFigure;
procedure ScanFillLines;
procedure SetFigureColor;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormPaint(Sender: TObject);
var
X1,Y1,X2,Y2: Integer;
NewRect: TRect;
I,J: Byte;
CurSheet: TFigureWorksheet;
NextColor: TColor;
begin
if RedrawSheet then FillChar(OldGlassWorkSheet,SizeOf(OldGlassWorkSheet),#255);
for I := 1 to GlassHeight do
for J := 1 to GlassWidth do begin
if GlassWorkSheet[I,J]=OldGlassWorkSheet[I,J] then Continue;
X1 := LeftOfs+(J-1)*BarWidth;
X2 := X1+BarWidth;
Y1 := TopOfs+(I-1)*BarHeight;
Y2 := Y1+BarHeight;
case GlassWorkSheet[I,J] of
0: Canvas.Brush.Color := clNavy;
1: Canvas.Brush.Color := clSilver;
2: Canvas.Brush.Color := clRed;
3: Canvas.Brush.Color := clLime;
4: Canvas.Brush.Color := clBlue;
5: Canvas.Brush.Color := clFuchsia;
6: Canvas.Brush.Color := clAqua;
7: Canvas.Brush.Color := clYellow;
8: Canvas.Brush.Color := clWhite;
end;
if GlassWorkSheet[I,J]>0 then begin
NewRect := Rect(X1+1,Y1+1,X2-1,Y2-1);
Canvas.FillRect(NewRect);
Canvas.Pen.Color := clGray;
Canvas.MoveTo(X1,Y1);
Canvas.LineTo(X1,Y2-1);
Canvas.LineTo(X2-1,Y2-1);
Canvas.Pen.Color := clWhite;
Canvas.LineTo(X2-1,Y1);
Canvas.LineTo(X1,Y1);
end
else begin
NewRect := Rect(X1,Y1,X2,Y2);
Canvas.FillRect(NewRect);
end;
end;
case FirstFigure of
0: Move(Triada,CurSheet,SizeOf(CurSheet));
1: Move(LCorner,CurSheet,SizeOf(CurSheet));
2: Move(RCorner,CurSheet,SizeOf(CurSheet));
3: Move(LZigzag,CurSheet,SizeOf(CurSheet));
4: Move(RZigzag,CurSheet,SizeOf(CurSheet));
5: Move(Stick,CurSheet,SizeOf(CurSheet));
6: Move(Box,CurSheet,SizeOf(CurSheet));
7: Move(Add1,CurSheet,SizeOf(CurSheet));
8: Move(Add2,CurSheet,SizeOf(CurSheet));
end;
case FirstColor of
0: NextColor := clNavy;
1: NextColor := clSilver;
2: NextColor := clRed;
3: NextColor := clLime;
4: NextColor := clBlue;
5: NextColor := clFuchsia;
6: NextColor := clAqua;
7: NextColor := clYellow;
8: NextColor := clWhite;
end;
for I := 1 to MaxFigureSize-2 do
for J := 1 to MaxFigureSize do begin
X1 := NextLeftOfs+(J-1)*NextBarWidth;
X2 := X1+NextBarWidth;
Y1 := NextTopOfs+(I-1)*NextBarHeight;
Y2 := Y1+NextBarHeight;
if CurSheet[I,J]>0 then begin
NewRect := Rect(X1+1,Y1+1,X2-1,Y2-1);
Canvas.Brush.Color := NextColor;
Canvas.FillRect(NewRect);
Canvas.Pen.Color := clGray;
Canvas.MoveTo(X1,Y1);
Canvas.LineTo(X1,Y2-1);
Canvas.LineTo(X2-1,Y2-1);
Canvas.Pen.Color := clWhite;
Canvas.LineTo(X2-1,Y1);
Canvas.LineTo(X1,Y1);
end
else begin
Canvas.Brush.Color := clSilver;
NewRect := Rect(X1,Y1,X2,Y2);
Canvas.FillRect(NewRect);
end;
end;
Move(GlassWorkSheet,OldGlassWorkSheet,SizeOf(OldGlassWorkSheet));
end;
function TForm1.FigureXSize: Byte;
var
I,J,K: Byte;
begin
K := 0;
for J := 1 to MaxFigureSize do
for I := 1 to MaxFigureSize do
if FigureWorkSheet[J,I]>0 then
if K<I then K := I;
FigureXSize := K;
end;
function TForm1.FigureYSize: Byte;
var
I,J,K: Byte;
begin
K := 0;
for J := 1 to MaxFigureSize do
for I := 1 to MaxFigureSize do
if FigureWorkSheet[J,I]>0 then
if K<J then K := J;
FigureYSize := K;
end;
procedure TForm1.GenerateNewFigure;
begin
Timer.Enabled := False;
SecondFigure := FirstFigure;
SecondColor := FirstColor;
FigureType := SecondFigure;
FigureX := 5;
FigureY := 0;
FigureCorner := fc270;
FillChar(FigureWorkSheet,SizeOf(FigureWorkSheet),0);
case FigureType of
0: Move(Triada,FigureWorkSheet,SizeOf(FigureWorkSheet));
1: Move(LCorner,FigureWorkSheet,SizeOf(FigureWorkSheet));
2: Move(RCorner,FigureWorkSheet,SizeOf(FigureWorkSheet));
3: Move(LZigzag,FigureWorkSheet,SizeOf(FigureWorkSheet));
4: Move(RZigzag,FigureWorkSheet,SizeOf(FigureWorkSheet));
5: Move(Stick,FigureWorkSheet,SizeOf(FigureWorkSheet));
6: Move(Box,FigureWorkSheet,SizeOf(FigureWorkSheet));
7: Move(Add1,FigureWorkSheet,SizeOf(FigureWorkSheet));
8: Move(Add1,FigureWorkSheet,SizeOf(FigureWorkSheet));
end;
SetFigureColor;
FigureMove := mdDown;
FirstFigure := Random(MaxFigureNumber);
FirstColor := Random(MaxFigureColor)+1;
Timer.Enabled := True;
end;
procedure TForm1.ClearFigureIntoGlass;
var
I,J: Byte;
begin
for J := 1 to FigureYSize do
for I := 1 to FigureXSize do
if FigureWorkSheet[J,I]>0 then
GlassWorkSheet[FigureY+J,FigureX+I] := 0;
end;
function TForm1.PutFigureIntoGlass(MoveDirect: TMoveDirect): Boolean;
var
I,J: Byte;
begin
PutFigureIntoGlass := True;
if (FigureY+FigureYSize>GlassHeight) and (MoveDirect=mdDown) then begin
Dec(FigureY);
PutFigureIntoGlass := False;
Exit;
end
else
while (FigureX+FigureXSize>GlassWidth) and (MoveDirect=mdDown) do
Dec(FigureX);
for J := 1 to FigureYSize do begin
for I := 1 to FigureXSize do begin
if (FigureWorkSheet[J,I]>0) and
(GlassWorkSheet[FigureY+J,FigureX+I]>0) then begin
PutFigureIntoGlass := False;
case MoveDirect of
mdDown: Dec(FigureY);
mdRight: Dec(FigureX);
mdLeft: Inc(FigureX);
end;
Exit;
end;
end;
end;
for J := 1 to FigureYSize do
for I := 1 to FigureXSize do
if FigureWorkSheet[J,I]>0 then
GlassWorkSheet[FigureY+J,FigureX+I] := FigureWorkSheet[J,I];
RedrawSheet := False;
FormPaint(Self);
RedrawSheet := True;
end;
procedure TForm1.ScanFillLines;
var
I,J,K,L: byte;
begin
ClearFigureIntoGlass;
for I := 1 to GlassHeight do begin
K := 0;
for J := 1 to GlassWidth do
if GlassWorkSheet[I,J]>0 then Inc(K);
if K=GlassWidth then begin
for L := I downto 1 do
for J := 1 to GlassWidth do
if L>1 then GlassWorkSheet[L,J] := GlassWorkSheet[L-1,J];
end;
end;
PutFigureIntoGlass(FigureMove);
end;
procedure TForm1.TimerTimer(Sender: TObject);
var
I,J: Byte;
begin
if ReentTimer then Exit
else ReentTimer := True;
if StrToInt(lblLevel.Caption)<>Level then lblLevel.Caption := IntToStr(Level);
if StrToInt(lblCount.Caption)<>Score then lblCount.Caption := IntToStr(Score);
if not FigureActive then begin
GenerateNewFigure;
if not PutFigureIntoGlass(FigureMove) then
begin
Application.MessageBox('完了！',Pchar(Application.Title),MB_ICONEXCLAMATION);
FillChar(OldGlassWorkSheet,SizeOf(OldGlassWorkSheet),#255);
Timer.Enabled := False;
ClearFigureIntoGlass;
FigureActive := False;
Level := 1;
Score := 0;
for I := 1 to GlassHeight do
for J := 1 to GlassWidth do GlassWorkSheet[I,J] := 0;
RedrawSheet := False;
FormPaint(Self);
RedrawSheet := True;
end;
FigureActive := True;
end
else begin
ClearFigureIntoGlass;
Inc(FigureY);
if not PutFigureIntoGlass(FigureMove) then begin
case FigureType of
0: Inc(Score,10);
1,2: Inc(Score,30);
3,4,7,8: Inc(Score,25);
5: Inc(Score,15);
6: Inc(Score,20);
end;
if Score>300 then Level := 2;
if Score>700 then Level := 3;
if Score>1300 then Level := 4;
if Score>2000 then Level := 5;
if Score>3000 then Level := 6;
if Score>5000 then Level := 7;
Timer.Interval := Round((7.1-Level)*100);
FigureActive := False;
end;
end;
ScanFillLines;
ReentTimer:=False;
end;
procedure TForm1.RotateFigure;
var
CurSheet: TFigureWorksheet;
OldFigureCorner: TFigureCorner;
procedure RotateFigureWorksheet;
var
VertFlag: Byte;
HorizFlag: Byte;
K,I,J: Byte;
begin
FillChar(FigureWorkSheet,SizeOf(FigureWorkSheet),0);
case FigureType of
0: Move(Triada,FigureWorkSheet,SizeOf(FigureWorkSheet));
1: Move(LCorner,FigureWorkSheet,SizeOf(FigureWorkSheet));
2: Move(RCorner,FigureWorkSheet,SizeOf(FigureWorkSheet));
3: Move(LZigzag,FigureWorkSheet,SizeOf(FigureWorkSheet));
4: Move(RZigzag,FigureWorkSheet,SizeOf(FigureWorkSheet));
5: Move(Stick,FigureWorkSheet,SizeOf(FigureWorkSheet));
6: Move(Box,FigureWorkSheet,SizeOf(FigureWorkSheet));
7: Move(Add1,FigureWorkSheet,SizeOf(FigureWorkSheet));
8: Move(Add1,FigureWorkSheet,SizeOf(FigureWorkSheet));
end;
FillChar(CurSheet,SizeOf(CurSheet),0);
for K := 0 to Byte(FigureCorner) do begin
for I := 1 to MaxFigureSize do
for J := 1 to MaxFigureSize do
CurSheet[J,I] := FigureWorkSheet[MaxFigureSize-I+1,J];
Move(CurSheet,FigureWorkSheet,SizeOf(FigureWorkSheet));
end;
SetFigureColor;
HorizFlag := 0;
while HorizFlag=0 do begin
for I := 1 to MaxFigureSize do
if FigureWorkSheet[1,I]>0 then HorizFlag := 1;
if HorizFlag=0 then begin
for J := 1 to MaxFigureSize-1 do
for I := 1 to MaxFigureSize do
FigureWorkSheet[J,I] := FigureWorkSheet[J+1,I];
for J := 1 to MaxFigureSize do
FigureWorkSheet[MaxFigureSize,J] := 0;
end;
end;
VertFlag := 0;
while VertFlag=0 do begin
for J := 1 to MaxFigureSize do
if FigureWorkSheet[J,1]>0 then VertFlag := 1;
if VertFlag=0 then begin
for J := 1 to MaxFigureSize do
for I := 1 to MaxFigureSize-1 do
FigureWorkSheet[J,I] := FigureWorkSheet[J,I+1];
for J := 1 to MaxFigureSize do
FigureWorkSheet[J,MaxFigureSize] := 0;
end;
end;
end;
begin
ClearFigureIntoGlass;
OldFigureCorner := FigureCorner;
if FigureCorner>fc00 then Dec(FigureCorner)
else FigureCorner := fc270;
RotateFigureWorksheet;
if not PutFigureIntoGlass(mdDown) then begin
FigureCorner := OldFigureCorner;
RotateFigureWorksheet;
PutFigureIntoGlass(mdDown);
end;
end;
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if ReentKeys then exit
else ReentKeys:=True;
if not FigureActive then
begin
ReentKeys:=False;
exit;
end;
case Key of
VK_UP,Ord('W'): RotateFigure;
VK_DOWN,Ord('S'),
VK_SPACE: begin
repeat
ClearFigureIntoGlass;
Inc(FigureY);
until not PutFigureIntoGlass(mdDown);
Inc(Score,5);
end;
VK_LEFT,
Ord('A'): if FigureX>0 then begin
ClearFigureIntoGlass;
Dec(FigureX);
PutFigureIntoGlass(mdLeft);
end;
VK_RIGHT,
Ord('D'): if FigureX+FigureXSize<GlassWidth then begin
ClearFigureIntoGlass;
Inc(FigureX);
PutFigureIntoGlass(mdRight);
end;
end;
ReentKeys := False;
end;
procedure TForm1.SetFigureColor;
var
I,J: Byte;
begin
for I := 1 to MaxFigureSize do
for J := 1 to MaxFigureSize do
if FigureWorkSheet[I,J]>0 then
FigureWorkSheet[I,J]:=SecondColor;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
OpenGame;
end;
procedure TForm1.OpenGame;
begin
BevelT.Visible:=True;
FillChar(OldGlassWorkSheet,SizeOf(OldGlassWorkSheet),#255);
RedrawSheet:=True;
Level:=1;
Timer.Interval:=Round((6.5-Level)*100);
Score:=0;
ReentTimer:=False;
ReentKeys:=False;
FigureActive:=False;
lblLevel.Caption:='1';
lblCount.Caption:='0';
Randomize;
FirstFigure:=Random(MaxFigureNumber);
FirstColor:=Random(MaxFigureColor)+1;
NextLeftOfs:=160;
NextTopOfs:=180;
OnKeyPress:=NIL;
OnPaint:=FormPaint;
end;
procedure TForm1.LblStartClick(Sender: TObject);
var
I,J: Byte;
begin
Timer.Enabled := False;
ClearFigureIntoGlass;
FigureActive := False;
Level:=1;
Score:=0;
for I:=1 to GlassHeight do
for J:=1 to GlassWidth do GlassWorkSheet[I,J] := 0;
RedrawSheet:=False;
FormPaint(Self);
RedrawSheet:=True;
Timer.Enabled:=True;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Timer.Enabled:=Not Timer.Enabled;
button1.Caption:='继续';
if Timer.Enabled then
button1.Caption:='暂停';
end;
end.
dfm文件：
object Form1: TForm1
Left = 358
Top = 157
HelpContext = 600
BorderStyle = bsDialog
Caption = #23567#28216#25103' - '#25913#20889#33258'Simple Tetris'
ClientHeight = 333
ClientWidth = 217
Color = clBtnFace
Font.Charset = GB2312_CHARSET
Font.Color = clWindowText
Font.Height = -12
Font.Name = #23435#20307
Font.Style = []
KeyPreview = True
OldCreateOrder = True
Position = poScreenCenter
OnCreate = FormCreate
OnKeyDown = FormKeyDown
PixelsPerInch = 96
TextHeight = 12
object Label1: TLabel
Left = 160
Top = 231
Width = 24
Height = 12
Caption = #31561#32423
end
object Label2: TLabel
Left = 160
Top = 274
Width = 24
Height = 12
Caption = #24471#20998
end
object lblLevel: TLabel
Left = 160
Top = 250
Width = 12
Height = 12
Caption = '99'
Font.Charset = GB2312_CHARSET
Font.Color = clRed
Font.Height = -12
Font.Name = #23435#20307
Font.Style = []
ParentFont = False
end
object lblCount: TLabel
Left = 160
Top = 291
Width = 30
Height = 12
Caption = '99999'
Font.Charset = GB2312_CHARSET
Font.Color = clRed
Font.Height = -12
Font.Name = #23435#20307
Font.Style = []
ParentFont = False
end
object BevelT: TBevel
Left = 3
Top = 4
Width = 145
Height = 326
Visible = False
end
object Label3: TLabel
Left = 158
Top = 152
Width = 36
Height = 12
Caption = #19979#19968#20010
end
object Button1: TButton
Left = 160
Top = 308
Width = 45
Height = 22
Caption = #24320#22987
TabOrder = 0
OnClick = Button1Click
end
object Timer: TTimer
Enabled = False
Interval = 100
OnTimer = TimerTimer
Left = 4
Top = 4
end
end
