Old Version of Pascal games in Tetris

Old Version of Tetris Huai (comments)

{$ 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; // score, Level
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); // select an empty paint brush
Hbrush: = createsolidbrush (RGB (255, 0, 128); // create a pink brush
SelectObject (DC, hbrush); // select the pink brush we created
Rectangle (DC, X, Y, x + Pm, Y + Pm); // draw a pink rectangle.
Deleteobject (hbrush); // Delete the newly created pink brush

SelectObject (DC, getstockobject (white_pen); // SELECT A WHITE BRUSH
Movetoex (DC, x + 24, Y, nil );
Lineto (DC, x, y );
Lineto (DC, X, Y + 24 );
Hpen: = createpen (ps_solid, 1, RGB (100,100,100); // create a gray paint brush
SelectObject (DC, Hpen); // select the gray paint brush we just created
Lineto (DC, x + 24, Y + 24 );
Lineto (DC, x + 24, y );
Deleteobject (Hpen); // Delete the gray paint brush we just created
End;

// Not complete, to be pasted back, transmitted
Procedure drawnextmap ();
VaR
I, J: integer;
Begin
SelectObject (DC, getstockobject (black_pen); // select a black brush
SelectObject (DC, getstockobject (black_brush); // select a black brush
Rectangle (DC, 277,66, 277 + pm * 4); // first draw a bigmap black rectangular background
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); // set the background color of the font to gray, consistent with the window background
Textout (DC, 300,220, pchar (scorestring), length (scorestring); // output score
Textout (DC, 300,270, pchar (levelstring), length (levelstring); // output pass count
// 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: = 'score: '+ scorestring + '';
Level: = 0;
STR (Level, levelstring );
Levelstring: = 'level: '+ 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
0: inttemppiece: = piece [0]; // Square
1: inttemppiece: = piece [2]; // I
2: inttemppiece: = piece [1]; // I
3: inttemppiece: = piece [4]; // Z
4: inttemppiece: = piece [3]; // Z
5: inttemppiece: = piece [6]; // anti-z
6: inttemppiece: = piece [5]; // anti-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]; // anti-l
16, 17, 18: inttemppiece: = piece [I-1]; // anti-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 // when the overlapped lattice is 1, the table cannot be deformed.
Begin
Canturn: = false;
R: = false;
Exit;
End;
Intcurpiece: = inttemppiece;
Inttocurpiece ();
Canturn: = R;
End;

// Not complete, to be pasted back, transmitted
Function canright (): Boolean;
VaR
I, J: integer;
Begin
INC (xpos); // assume that the square continues to the right
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 // when the overlapped lattice is 1, it indicates that the right shift cannot be performed.
Begin
Dec (xpos );
Canright: = false;
Exit;
End;
Dec (xpos );
Canright: = true;
End;

Function canleft (): Boolean;
VaR
I, J: integer;
Begin
Dec (xpos); // assume that the square continues to the left
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 // when the number of overlapped grids is 1, it indicates that the value cannot be shifted to the left.
Begin
INC (xpos );
Canleft: = false;
Exit;
End;
INC (xpos );
Canleft: = true;
End;

Function candown (): Boolean; // determines whether curpiece can continue to fall
VaR
I, J: integer;
Begin
INC (ypos); // assume that the square continues to fall
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 // when the number of overlapped grids is 1, the table cannot be dropped.
Begin
Dec (ypos );
Candown: = false;
Exit;
End;
Dec (ypos );
Candown: = true;
End;

Procedure fillbigmap (); // record a large image
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; // whether the game is over or not
VaR
I: integer;
R: Boolean;
Begin
R: = false;
For I: = 1 to 10 do
If bigmap [I] [0] Then // when the top row has a small value of 1, return true
Begin
R: = true;
Break
End;
Isgameover: = R;
End;

Procedure clearline (); // cancel a row
VaR
Linescount, Count, I, J, K, M: integer;
Begin
Linescount: = 0; // The number of rows that are consumed at a time
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, indicates that the row is full.
Begin
INC (linescount );
For K: = J downto 1 do
For M: = 1 to 10 do
Bigmap [m] [k]: = bigmap [m] [k-1];
// Inc (j); // What should I do ????
If (linescount> 0) then
Begin
Score: = score + linescount * 10;
STR (score, scorestring );
Scorestring: = 'score: '+ scorestring + '';

If (level <> (score Div 1000) then
Begin
Level: = score Div 1000;
STR (Level, levelstring );
Levelstring: = 'level: '+ 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 // if you can continue to fall
Ypos: = ypos + 1 // then the curpiece falls (the ordinate plus 1)
Else // if not
Begin
Fillbigmap (); // enter curpiece in bigmap
Intcurpiece: = intnextpiece;
Inttocurpiece ();

Intnextpiece: = newpiece (); // randomly generate new blocks and copy them to nextpiece
Inttonextpiece ();
Xpos: = 4; // the abscissa is initialized to 4.
Ypos: =-4; // The ordinate value is initialized to-1.
Clearline (); // cancel the line
If (isgameover () then
Begin
Killtimer (window, 11 );
Isgameing: = false;
MessageBox (window, 'game is over! "',' Hint ', mb_ OK );
End;

End;
Postmessage (window, wm_paint, 0, 0 );
End;

Procedure begingame ();
Begin
Init ();
Randomize;
Intcurpiece: = newpiece (); // randomly generate new blocks and copy them to nextpiece
Inttocurpiece ();//
Intnextpiece: = newpiece (); // randomly generate new blocks and copy them to nextpiece
Inttonextpiece ();
Isgameing: = true;
Speed:= 1000;
Settimer (hwindow, 11, speed, @ timerproc); // The timer ID is 11, the interval is 1000 ms, and the time callback function is timerproc ()
End;
// Not complete, to be pasted back, transmitted
Function windowproc (window: hwnd; amessage: uint; wparam: wparam;
Lparam: lparam): lresult; stdcall; export;

VaR
Nrmenu: longint;
Aboutstring: string;

Begin
Windowproc: = 0;

Case amessage

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
Createmediawex (0, 'click', 'start ',
Ws_child or ws_visible or bs_pushbutton,
20, 10, 75, 40,
Window,
0, system. maininstance, nil );

Createmediawex (0, 'button ', 'pause ',
Ws_child or ws_visible or bs_pushbutton,
100,10, 75,40,
Window,
1, system. maininstance, nil );

Createmediawex (0, 'click', 'upgrade ',
Ws_child or ws_visible or bs_pushbutton,
,
Window,
2, system. maininstance, nil );

Createmediawex (0, 'button ', 'about ',
Ws_child or ws_visible or bs_pushbutton,
, 10,
Window,
3, system. maininstance, nil );
End;
Wm_command:
Begin
Nrmenu: = wparam and $ FFFF;
Case nrmenu
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: = 'taobao.com's product must be a boutique '+ CHR (13) + CHR (10 );
Aboutstring: = aboutstring + 'chaobs honors '+ CHR (13) + CHR (10 );
Aboutstring: = aboutstring + 'webpage: hi.baidu.com/chaobs ';
MessageBox (window, pchar (aboutstring), 'meet the old chaobs honor product', mb_ OK );
Postmessage (window, wm_command, 2, 0 );
End;
End;
Setfocus (window); // return the focus to the main window.
End;

Wm_keydown:
Begin
If (isgameing) then
Begin
Nrmenu: = wparam and $ FFFF;
Case nrmenu
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, 'tetris with old chaobs honors output ',
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.