Pascal小游戏 俄罗斯方块怀旧版

俄罗斯方块怀旧版（注释版）

{$APPTYPE GUI}
{$MODE DELPHI}
program WinPiece;

uses
Windows;

const
AppName = ‘WinPiece‘;
pm = 25;

var
dc : hdc;
AMessage : Msg;
hWindow: HWnd;
hPen ,hBrush : longword;
intNextPiece, intCurPiece,intTempPiece : longint;
BigMap : array [0..11,-4..20] of boolean;
NextPiece,CurPiece,TempPiece : array [0..3,0..3] of boolean;
isGameing : boolean;
Piece : array [0..18] of longint;
scoreString, levelString: string;
xPos, yPos : integer;
score,level : longint; //分数,关卡
speed : integer;

procedure TimerProc(Window:HWND;uMsg:UINT;idEvent:UINT;Time:DWORD);stdcall;
FORWARD;

Procedure IntToNextPiece ( );
var
i,j : integer;
t: longint;
begin

t:=intNextPiece;
For i:=0 TO 3 DO
For j:=0 TO 3 DO
begin
If (t mod 2=1) Then
NextPiece[j][i] := true
else
NextPiece[j][i] := false ;

t := t div 2;
end;

end;

Procedure IntToCurPiece ( );
var
i,j : integer;
t : longint;
begin
t:=intCurPiece;
For i:=0 TO 3 DO
For j:=0 TO 3 DO
begin
If (t mod 2=1) Then
CurPiece[j][i] := true
else
CurPiece[j][i] := false ;
t := t div 2;
end;
end;

Procedure IntToTempPiece ( );
var
i,j : integer;
t : longint;
begin
t:=intTempPiece;
For i:=0 TO 3 DO
For j:=0 TO 3 DO
begin
If (t mod 2=1) Then
TempPiece[j][i] := true
else
TempPiece[j][i] := false ;
t := t div 2;
end;
end;

Procedure DrawPiece(x,y:integer);
begin
SelectObject (dc,GetStockObject (NULL_PEN)) ; //选择空画笔 
hBrush := CreateSolidBrush (RGB(255,0,128)); //创建粉色笔刷 
SelectObject (dc,hBrush) ; //选择我们创建的粉色笔刷 
Rectangle(dc,x,y,x+pm,y+pm); //画粉色矩形 
DeleteObject(hBrush); //删除刚创建的粉色笔刷

SelectObject (dc,GetStockObject (WHITE_PEN)) ; //选择白色画笔 
MoveToEx (dc, x+24,y, nil);
LineTo(dc,x,y);
LineTo(dc,x,y+24);
hPen:=CreatePen(PS_SOLID,1, RGB(100,100,100)); //创建灰色画笔 
SelectObject (dc,hPen) ; //选择我们刚创建的灰色画笔 
LineTo(dc,x+24,y+24);
LineTo(dc,x+24,y);
DeleteObject(hPen); //删除我们刚创建的灰色画笔 
end;

//未完，待回贴，传送
Procedure DrawNextMap( );
var
i, j : integer;
begin
SelectObject (dc,GetStockObject (BLACK_PEN)); //选择黑色画笔 
SelectObject (dc,GetStockObject (BLACK_BRUSH)); //选择黑色画笔 
Rectangle(dc,277,66,277+pm*4,66+pm*4); //先画BigMap黑色矩形背景
IntToNextPiece();
SelectObject (dc,GetStockObject (WHITE_PEN)) ;
For i:= 0 to 3 DO
begin
For j:=0 TO 3 DO
begin
If NextPiece[i][j] Then
begin
DrawPiece(277+pm*i,66+pm*j);
end;
end;
end; 
end;

Procedure DrawBigMap( );
var
i, j:integer;
begin
For i:= 1 TO 10 DO
begin
For j:= 0 TO 19 DO
begin
If BigMap[i][j] Then
DrawPiece(12+(i-1)*pm,66+j*pm)
else
begin
SelectObject (dc, GetStockObject (BLACK_PEN)) ;
SelectObject (dc, GetStockObject (BLACK_BRUSH)) ;
Rectangle(dc,12+(i-1)*pm,66+j*pm,12+(i-1)*pm+pm,66+j*pm+pm);
end;
end;
end;
end;

Procedure DrawCurMap();
var
i, j : integer;
begin
IntToCurPiece();
For i:=0 TO 3 DO
For j:= 0 TO 3 DO
If (CurPiece[i][j]) and (yPos+j>=0) Then DrawPiece(12+(xPos+i-1)*pm,66+(yPos+j)*pm);
end;

Procedure DrawScore ( );
begin
SetBkColor(dc,RGB(200,200,200)); //设置字体的背景色为灰色，以与窗口背景保持一致 
TextOut(dc,300,220,PChar(scoreString),length(scoreString)); //输出分数 
TextOut(dc, 300, 270, PChar(levelString),length(levelString)); //输出过关数 
//MessageBox(0,‘‘,‘‘,MB_OK);
end;

function NewPiece ( ):longint;
begin
NewPiece:=Piece[trunc(random*19)];
end;

Procedure init ( );
var
i, j : integer;
begin
For i:=0 TO 11 DO
For j:=-4 TO 20 DO
If (i=0) or (i=11) or (j=20) Then
BigMap[i][j] := true
else
BigMap[i][j] := false ;

score:=0;
str(score,scoreString);
scoreString:=‘分数：‘+ scoreString + ‘ ‘;
level:=0; 
str(level,levelString);
levelString:=‘级别：‘+ levelString +‘ ‘;
xPos:=4;
yPos:=-4;
end;

function CanTurn(): boolean;
var
i,j: integer;
r: boolean;
begin
r:=true ;
For i:=0 TO 18 DO
If intCurPiece=Piece[i] Then
begin
break ;
end;
case i of
0: intTempPiece := Piece[0]; //方块
1: intTempPiece := Piece[2]; //i
2: intTempPiece := Piece[1]; //i
3: intTempPiece := Piece[4]; //z
4: intTempPiece := Piece[3]; //z
5: intTempPiece := Piece[6]; //反z
6: intTempPiece := Piece[5]; //反z
7: intTempPiece := Piece[10]; //T
8, 9, 10: intTempPiece := Piece[i - 1]; //T
11: intTempPiece := Piece[14]; //L
12, 13, 14: intTempPiece := Piece[i - 1]; //L
15: intTempPiece := Piece[18]; //反L
16, 17, 18: intTempPiece := Piece[i - 1]; //反L
end;

IntToTempPiece ( );
For i:=0 TO 3 DO
For j:=0 TO 3 DO
If (((xPos+i)>=0) and ((xPos+i)<12) and (BigMap[xPos+i][yPos+j]) and (TempPiece[i][j])) Then //当有重合的格子都为1时，表示表不能变形
begin
CanTurn:=false ;
r:=false;
exit ;
end;
intCurPiece:=intTempPiece;
intToCurPiece();
CanTurn:=r;
end;

//未完，待回贴，传送
Function CanRight ( ) : boolean;
var
i,j: integer;
begin
inc(xPos); //假设方块继续右
For i:=0 TO 3 DO
For j:=0 TO 3 DO
If (((xPos+i)>=0) and ((xPos+i)<12) and (BigMap[xPos+i][yPos+j]) and (CurPiece[i][j])) Then //当有重合的格子都为1时，表示不能右移
begin
dec(xPos);
CanRight:=false ;
exit ;
end;
dec(xPos);
CanRight := true ;
end;

Function CanLeft ( ) : boolean;
var
i,j: integer;
begin
dec(xPos); //假设方块继续左
For i:=0 TO 3 DO
For j:=0 TO 3 DO
If (((xPos+i)>=0) and ((xPos+i)<12) and (BigMap[xPos+i][yPos+j]) and (CurPiece[i][j])) Then //当有重合的格子都为1时，表示不能左移
begin
inc(xPos);
CanLeft:=false ;
exit ;
end;
inc(xPos);
CanLeft := true ;
end;

Function CanDown ( ) : boolean; //判断CurPiece能否继续下落 
var
i,j: integer;
begin
inc(yPos); //假设方块继续下落
For i:=0 TO 3 DO
For j:=0 TO 3 DO
If (((xPos+i)>=0) and ((xPos+i)<12) and (yPos+j>=0) and (BigMap[xPos+i][yPos+j]) and (CurPiece[i][j])) Then //当有重合的格子都为1时，不能表示表能下落了 
begin
dec(yPos);
CanDown:=false ;
exit ;
end;
dec(yPos);
CanDown := true ;
end;

Procedure FillBigMap ( ); //记录大图
var
i, j : integer;
begin
For i:=0 TO 3 DO
For j:=0 TO 3 DO
If CurPiece[i][j] Then
BigMap[xPos+i][yPos+j]:=true;

end;

Function IsGameOver ( ) : boolean; //游戏是过否结束
var
i:integer;
r:boolean;
begin
r:=false ;
For i:=1 TO 10 DO 
If BigMap[i][0] Then //当 最上一行有小格为1，返回真
begin
r:=true ;
break 
end;
IsGameOver := r ;
end;

Procedure ClearLine ( ); //消行 
var
linesCount, count, i, j, k, m: integer;
begin
linesCount := 0; //一次消行的行数 
For j:=19 downTO 0 DO
begin
count:=0;
For i:=1 TO 10 DO
If BigMap[i][j] Then
inc(count);
If count=10 Then //count=10，表明该行已满 
begin
inc(linesCount);
For k:= j downTO 1 DO
For m:= 1 TO 10 DO
BigMap[m][k]:=BigMap[m][k-1];
//inc(j); //这个怎么办????
if(linesCount>0) then
begin
score:=score+linesCount*10;
str(score,scoreString);
scoreString:=‘分数：‘+ scoreString + ‘ ‘;

if( level<>(score div 1000) ) then
begin
level := score div 1000;
str(level,levelString);
levelString:=‘级别：‘+ levelString + ‘ ‘;
KillTimer(hwindow,11);
speed:=speed div 2;
SetTimer(hWindow,11,speed,@TimerProc);
end;

end;
end;
end;
end;

procedure TimerProc(Window:HWND;uMsg:UINT;idEvent:UINT;Time:DWORD);stdcall;
begin
If (CanDown()) then //如果能继续下落 
yPos := yPos + 1 //则CurPiece下落（纵坐标加1 ） 
else //如果不能下落
begin
FillBigMap(); //将CurPiece填入BigMap
intCurPiece:=intNextPiece;
IntToCurPiece();

intNextPiece:=NewPiece(); //随机产生新方块，并复制给NextPiece
IntToNextPiece();
xPos:=4; //横坐标初始化为4 
yPos:=-4; //纵坐标初始化为-1 
ClearLine(); //消行 
if(IsGameOver()) then
begin
KillTimer(window,11);
isGameing:=false ;
MessageBox(window,‘游戏结束！"‘,‘提示‘,MB_OK); 
end;

end;
PostMessage(window, WM_PAINT, 0, 0);
end;

Procedure BeginGame ( );
begin
init();
randomize;
intCurPiece:=NewPiece(); //随机产生新方块，并复制给NextPiece
IntToCurPiece(); //
intNextPiece:=NewPiece(); //随机产生新方块，并复制给NextPiece
IntToNextPiece();
isGameing:=true;
speed:=1000;
SetTimer(hWindow,11,speed,@TimerProc); //定时器id为11，时间间隔为1000ms，时间回调函数是TimerProc()
end;
//未完，待回贴，传送
function WindowProc(Window: HWnd; AMessage: UINT; WParam : WPARAM;
LParam: LPARAM): LRESULT; stdcall; export;

var
nrmenu : longint;
aboutString : String;

begin
WindowProc := 0;

case AMessage of

wm_paint:
begin
DefWindowProc(Window, AMessage, WParam, LParam);
dc:= GetDC(window);

DrawBigMap();
DrawNextMap();
DrawCurMap();
DrawScore(); 
ReleaseDC(window, dc) ;
end;

wm_Destroy:
begin
PostQuitMessage(0);
Exit;
end;

wm_Create:
begin
CreateWindowEx(0,‘button‘,‘开始‘,
ws_child or ws_visible or bs_pushbutton,
20,10,75,40,
Window,
0,system.MainInstance,nil);

CreateWindowEx(0,‘button‘,‘暂停‘,
ws_child or ws_visible or bs_pushbutton,
100,10,75,40,
Window,
1,system.MainInstance,nil);

CreateWindowEx(0,‘button‘,‘继续‘,
ws_child or ws_visible or bs_pushbutton,
180,10,75,40,
Window,
2,system.MainInstance,nil);

CreateWindowEx(0,‘button‘,‘关于‘,
ws_child or ws_visible or bs_pushbutton,
260,10,75,40,
Window,
3,system.MainInstance,nil);
end;
wm_command:
begin
NrMenu := WParam And $FFFF;
case NrMenu of
0: 
begin
BeginGame();
end;
1:
If (not isGameOver()) and (isGameing) Then
begin
isGameing:=false ;
killTimer(window,11);
end;
2:
begin
If (not isGameOver()) and (not isGameing) Then
begin
isGameing:=true ;
SetTimer(hWindow,11,speed,@TimerProc);
end;
end;
3:
begin
PostMessage(window,wm_command,1,0);
aboutString := ‘嘲哥出品 必属精品‘+ chr(13) + chr(10);
aboutString :=aboutString + ‘chaobs荣誉出品‘ + chr(13) + chr(10);
aboutString :=aboutString + ‘网页：hi.baidu.com/chaobs‘;
messagebox(window,pchar(aboutString),‘俄罗斯方块怀旧版 Chaobs荣誉出品‘,mb_ok);
PostMessage(window,wm_command,2,0);
end;
end;
SetFocus(window); //把焦点归还给主窗口 
end;

WM_KEYDOWN:
begin
if(isGameing) then
begin
NrMenu := WParam And $FFFF;
case NrMenu of
VK_UP:
If CanTurn() Then
begin
PostMessage(window,WM_PAINT,0,0);
end;
VK_LEFT:
If CanLeft() Then
begin
dec(xpos);
PostMessage(window,WM_PAINT,0,0);
end;
VK_RIGHT:
If CanRight() Then
begin
inc(xpos);
PostMessage(window,WM_PAINT,0,0);
end;
VK_DOWN:
If CanDown() Then
begin
TimerProc(window,11,0,0);
end;
end;
end;
end;
end;

WindowProc := DefWindowProc(Window, AMessage, WParam, LParam);
end;

{ Register the Window Class }
function WinRegister: Boolean;
var
WindowClass: WndClass;
begin
WindowClass.Style := cs_hRedraw or cs_vRedraw;
WindowClass.lpfnWndProc := WndProc(@WindowProc);
WindowClass.cbClsExtra := 0;
WindowClass.cbWndExtra := 0;
WindowClass.hInstance := system.MainInstance;
WindowClass.hIcon := LoadIcon(0, idi_Application);
WindowClass.hCursor := LoadCursor(0, idc_Arrow);
WindowClass.hbrBackground := GetStockObject(WHITE_BRUSH);
WindowClass.lpszMenuName := nil;
WindowClass.lpszClassName := AppName;

WinRegister := RegisterClass(WindowClass) <> 0;
end;

{ Create the Window Class }
function WinCreate: HWnd;

begin
hWindow := CreateWindow(AppName, ‘俄罗斯方块怀旧版 Chaobs荣誉出品‘,
ws_OverlappedWindow, cw_UseDefault, cw_UseDefault,
400, 615, 0, 0, system.MainInstance, nil);

if hWindow <> 0 then
begin
ShowWindow(hWindow, CmdShow);
ShowWindow(hWindow, SW_SHOW);
UpdateWindow(hWindow);
end;

WinCreate := hWindow;
end;

Procedure VarInit( );
begin
Piece[0]:=13056;
Piece[1]:=8738;
Piece[2]:=3840;
Piece[3]:=25344;
Piece[4]:=4896;
Piece[5]:=13824;
Piece[6]:=8976;
Piece[7]:=29184;
Piece[8]:=17984;
Piece[9]:=9984;
Piece[10]:=4880;
Piece[11]:=25120;
Piece[12]:=29696;
Piece[13]:=17504;
Piece[14]:=5888;
Piece[15]:=12832;
Piece[16]:=18176;
Piece[17]:=8800;
Piece[18]:=28928;
end;

begin
VarInit();
if not WinRegister then
begin
MessageBox(0, ‘Register failed‘, nil, mb_Ok);
Exit;
end;
hWindow := WinCreate;
if longint(hWindow) = 0 then
begin
MessageBox(0, ‘WinCreate failed‘, nil, mb_Ok);
Exit;
end;

while GetMessage(@AMessage, 0, 0, 0) do
begin
TranslateMessage(AMessage);
DispatchMessage(AMessage);
end;
Halt(AMessage.wParam);
end.

Pascal小游戏 俄罗斯方块怀旧版,布布扣,bubuko.com

时间： 2024-12-27 21:17:41

Pascal小游戏 俄罗斯方块怀旧版的相关文章

Pascal小游戏 俄罗斯方块

俄罗斯方块已经成为了和“Hello World”一样的程序了吧? 不要直接复制,可能需要事先 Format. program cube;uses crt,graph,dos;var gd,gm:smallint;fillin:fillpatterntype;board:array[0..26,0..26]of boolean;cube1,cube2,cube3,cube4:array[1..2]of byte;h,min,s,ss,ls,i,j,k,r,lin,cu1,cu2,cu3,cu4,c

Pascal小游戏 双人射击

一个双人的游戏 Pascal源码附上 只要俩人不脑残,一下午玩不完...又是控制台游戏中的一朵奇葩. Free Pascal 射击游戏 Program shooting_game; uses crt; const cz:array[1..4,1..2] of -1..1=((0,1),(1,0),(0,-1),(-1,0)); var i,j,xz1,yz1,y1,xz2,yz2,y2,t1,t2,t3,k,v1,v2:integer;     ch:char;     a:array[1..2

Pascal小游戏 贪吃蛇

一段未完成的Pascal贪吃蛇 说这段代码未完成其实是没有源代码格式化,FP中一行最多只有255字符宽. uses crt; const screenwidth=50; screenheight=24; wallchar='#'; snakechar='*'; ; type point=record x,y:integer; end; var snake:array [0..500] of point; map:array [0..screenwidth,0..screenheight] of

Pascal小游戏 文件的产生

一个整人的Pascal小程序 运行之后硬盘里面会有一大堆垃圾,当然更好的方法当然不是这样做! var a,b,c,d:char;beginfor a:='0' to '9' dofor b:='0' to '9' dofor c:='0' to '9' dofor d:='0' to '9' dobeginassign(output,'C:\'+a+b+c+d+'.txt');rewrite(output);write(1);close(output);assign(output,'D:\'+a

Pascal小游戏 打飞机

一个经典的打飞机游戏(1)Pascal代码 十分经典,有一种街机的感觉 奇葩青年的又一控制台神作. uses crt; type list=record         ty,ax:integer;         end;      xy=record         bx,by:integer;         end;      l1=array[1..4,1..5]of char;      l2=array[1..5,1..6]of char;      l3=array[1..8,1

Pascal小游戏 随机函数

一个被人写滥了的小程序,新手学习,Pascal By Chaobs 初学者可以用它来学习随机函数的运用,当然你完全可以自己写一个随机函数. var   player1,player2:longint;   a,b,l,o,i,v:longint; w:boolean;begin   randomize;   write('A=');readln(player1);   write('B=');readln(player2);   b:=1;   i:=1;   while(player1>0)a

Pascal小游戏 不要消灭星星

不要消灭星星 Pascal小游戏 Chaobs改编自pascal吧 控制台小游戏嘛,就当是练习一下结构化的写法. program wxtw; uses crt; type      zbdy=record      x,y:integer; end; var n,i,x,y,t,sjs:integer;    ml:char; zb: array [1..12] of zbdy; begin    randomize;    sjs:=random(3);    zb[1].x:=15; zb[

Pascal小游戏 井字棋

一个很经典的井字棋游戏 Pascal源码Chaobs奉上 注意:1.有的FP版本不支持汉语,将会出现乱码.2.别想赢电脑了,平手不错了. 井字过三关: program TicTacToe; uses crt; var a:Array [1..3] of Array [1..3] of char; b:Array [1..3] of Array [1..3] of integer; i,n,g,e,p:integer; t:text; c:char; o:integer; r:integer; s

Pascal小游戏之奇葩的RPG

Pascal吧友作品 一个小RPG Chaobs转载 varplife,plifemax,patt,pre:integer;gr,ex,exmax:integer;alife,alife1,aatt,are:integer;name,fname:string;na:text;code,co:string;dz:integer;money:longint;mp,mpmax:integer;red,blue,knife,clothes:integer;i:integer;god:array[1..1