mirror of
https://gitlab.com/freepascal.org/fpc/pas2js.git
synced 2025-04-19 21:09:37 +02:00
* Tetris demo
This commit is contained in:
michael
parent
d7f9db17ed
commit
fc8ee39898
57
demo/tetris/tetris.css
Normal file
57
demo/tetris/tetris.css
Normal file
@ -0,0 +1,57 @@
|
||||
body {
|
||||
text-align: left;
|
||||
background: #ffffff;
|
||||
}
|
||||
|
||||
#tetris {
|
||||
display: flex;
|
||||
font: "16px Roboto";
|
||||
}
|
||||
|
||||
#my-canvas {
|
||||
background: #ffffff;
|
||||
margin-left: 10px;
|
||||
margin-top: 10px;
|
||||
width: 300px;
|
||||
height: 480px;
|
||||
}
|
||||
|
||||
.btn-primary {
|
||||
margin: 10px;
|
||||
background-color: lightskyblue;
|
||||
border-radius: 3px;
|
||||
border: 2px solid;
|
||||
height: 30px;
|
||||
padding-right: 15px;
|
||||
padding-left: 15px;
|
||||
font-weight: bold;
|
||||
}
|
||||
|
||||
.envelope {
|
||||
border-width: medium;
|
||||
border-color: grey;
|
||||
margin-left: 10px;
|
||||
margin-top: 10px;
|
||||
display: flex;
|
||||
border-spacing: 5px;
|
||||
border-style: solid;
|
||||
border-radius: 4px;
|
||||
padding: 3px;
|
||||
font-weight: bold;
|
||||
color: #194a8d;
|
||||
}
|
||||
|
||||
.label {
|
||||
margin-right:20px;
|
||||
}
|
||||
#score-envelope {
|
||||
}
|
||||
#level-envelope {
|
||||
}
|
||||
|
||||
#status-envelope {
|
||||
}
|
||||
|
||||
#controls-envelope {
|
||||
display: block; !important
|
||||
}
|
||||
49
demo/tetris/tetris.html
Normal file
49
demo/tetris/tetris.html
Normal file
@ -0,0 +1,49 @@
|
||||
<!doctype html>
|
||||
<html lang="en">
|
||||
<head>
|
||||
<meta http-equiv="Content-type" content="text/html; charset=utf-8">
|
||||
<meta name="viewport" content="wideth=device-width, initial-scale=1">
|
||||
<link rel="stylesheet" type="text/css" href="tetris.css">
|
||||
<title>Tetris using pas2js</title>
|
||||
<script src="tetris.js"></script>
|
||||
</head>
|
||||
<body>
|
||||
<div id="tetris">
|
||||
<div id="gameboard">
|
||||
<canvas id="my-canvas"></canvas>
|
||||
</div>
|
||||
<div id="info">
|
||||
<div id="logo">
|
||||
<img id="logo-img" src="tetrislogo.png" width="161" height="54"/>
|
||||
</div>
|
||||
<div id="score-envelope" class="envelope">
|
||||
<div id="score-label" class="label">Score:</div>
|
||||
<div id="score">0</div>
|
||||
</div>
|
||||
<div id="level-envelope" class="envelope">
|
||||
<div id="level-label" class="label">Level:</div>
|
||||
<div id="level">1</div>
|
||||
</div>
|
||||
<div id="status-envelope" class="envelope">
|
||||
<div id="status-label" class="label">Game status:</div>
|
||||
<div id="status">Playing</div>
|
||||
</div>
|
||||
<div id="controls-envelope" class="envelope">
|
||||
<div id="controls-label" class="label">Controls:</div>
|
||||
<div id="controls">
|
||||
<p><span id="control-left">Arrow-Left:</span> Move left</p>
|
||||
<p><span id="control-right">Arrow-Right:</span> Move right</p>
|
||||
<p><span id="control-down">Arrow-Down:</span> Move down</p>
|
||||
<p><span id="control-rotate">Arrow-up:</span> Rotate block</p>
|
||||
<p><span id="control-drop">Arrow-up:</span> Drop block</p>
|
||||
</div>
|
||||
</div>
|
||||
<button id="btn-reset" class="btn-primary">Restart</button>
|
||||
</div>
|
||||
</div>
|
||||
Sources: <a target="new" href="tetris.lpr">Program</a> <a target="new" href="utetris.pp">unit</a>.
|
||||
<script>
|
||||
window.addEventListener("load", rtl.run);
|
||||
</script>
|
||||
</body>
|
||||
</html>
|
||||
96
demo/tetris/tetris.lpi
Normal file
96
demo/tetris/tetris.lpi
Normal file
@ -0,0 +1,96 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<CONFIG>
|
||||
<ProjectOptions>
|
||||
<Version Value="12"/>
|
||||
<General>
|
||||
<Flags>
|
||||
<MainUnitHasCreateFormStatements Value="False"/>
|
||||
<MainUnitHasTitleStatement Value="False"/>
|
||||
<MainUnitHasScaledStatement Value="False"/>
|
||||
<Runnable Value="False"/>
|
||||
</Flags>
|
||||
<SessionStorage Value="InProjectDir"/>
|
||||
<Title Value="tetris"/>
|
||||
<UseAppBundle Value="False"/>
|
||||
<ResourceType Value="res"/>
|
||||
</General>
|
||||
<CustomData Count="5">
|
||||
<Item0 Name="MaintainHTML" Value="1"/>
|
||||
<Item1 Name="PasJSHTMLFile" Value="project1.html"/>
|
||||
<Item2 Name="PasJSPort" Value="0"/>
|
||||
<Item3 Name="PasJSWebBrowserProject" Value="1"/>
|
||||
<Item4 Name="RunAtReady" Value="1"/>
|
||||
</CustomData>
|
||||
<BuildModes>
|
||||
<Item Name="Default" Default="True"/>
|
||||
</BuildModes>
|
||||
<PublishOptions>
|
||||
<Version Value="2"/>
|
||||
<UseFileFilters Value="True"/>
|
||||
</PublishOptions>
|
||||
<RunParams>
|
||||
<FormatVersion Value="2"/>
|
||||
<Modes Count="0"/>
|
||||
</RunParams>
|
||||
<Units>
|
||||
<Unit>
|
||||
<Filename Value="tetris.lpr"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
</Unit>
|
||||
<Unit>
|
||||
<Filename Value="tetris.html"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
<CustomData Count="1">
|
||||
<Item0 Name="PasJSIsProjectHTMLFile" Value="1"/>
|
||||
</CustomData>
|
||||
</Unit>
|
||||
<Unit>
|
||||
<Filename Value="utetris.pp"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
</Unit>
|
||||
</Units>
|
||||
</ProjectOptions>
|
||||
<CompilerOptions>
|
||||
<Version Value="11"/>
|
||||
<Target>
|
||||
<Filename Value="tetris"/>
|
||||
</Target>
|
||||
<SearchPaths>
|
||||
<IncludeFiles Value="$(ProjOutDir)"/>
|
||||
<UnitOutputDirectory Value="js"/>
|
||||
</SearchPaths>
|
||||
<Parsing>
|
||||
<SyntaxOptions>
|
||||
<AllowLabel Value="False"/>
|
||||
<CPPInline Value="False"/>
|
||||
<UseAnsiStrings Value="False"/>
|
||||
</SyntaxOptions>
|
||||
</Parsing>
|
||||
<CodeGeneration>
|
||||
<TargetOS Value="browser"/>
|
||||
</CodeGeneration>
|
||||
<Linking>
|
||||
<Debugging>
|
||||
<GenerateDebugInfo Value="False"/>
|
||||
<UseLineInfoUnit Value="False"/>
|
||||
</Debugging>
|
||||
</Linking>
|
||||
<Other>
|
||||
<CustomOptions Value="-Jeutf-8 -Jirtl.js -Jc -Jminclude"/>
|
||||
<CompilerPath Value="$(pas2js)"/>
|
||||
</Other>
|
||||
</CompilerOptions>
|
||||
<Debugging>
|
||||
<Exceptions Count="3">
|
||||
<Item1>
|
||||
<Name Value="EAbort"/>
|
||||
</Item1>
|
||||
<Item2>
|
||||
<Name Value="ECodetoolError"/>
|
||||
</Item2>
|
||||
<Item3>
|
||||
<Name Value="EFOpenError"/>
|
||||
</Item3>
|
||||
</Exceptions>
|
||||
</Debugging>
|
||||
</CONFIG>
|
||||
28
demo/tetris/tetris.lpr
Normal file
28
demo/tetris/tetris.lpr
Normal file
@ -0,0 +1,28 @@
|
||||
program tetris;
|
||||
|
||||
{$mode objfpc}
|
||||
|
||||
uses
|
||||
browserapp, JS, Classes, SysUtils, Web, utetris;
|
||||
|
||||
type
|
||||
TTetrisApplication = class(TBrowserApplication)
|
||||
FTetris : TTetris;
|
||||
procedure doRun; override;
|
||||
end;
|
||||
|
||||
procedure TTetrisApplication.doRun;
|
||||
|
||||
begin
|
||||
FTetris:=TTetris.Create(Self);
|
||||
FTetris.Start;
|
||||
end;
|
||||
|
||||
var
|
||||
Application : TTetrisApplication;
|
||||
|
||||
begin
|
||||
Application:=TTetrisApplication.Create(nil);
|
||||
Application.Initialize;
|
||||
Application.Run;
|
||||
end.
|
||||
BIN
demo/tetris/tetrislogo.png
Normal file
BIN
demo/tetris/tetrislogo.png
Normal file
Binary file not shown.
|
After 
(image error) Size: 63 KiB |
637
demo/tetris/utetris.pp
Normal file
637
demo/tetris/utetris.pp
Normal file
@ -0,0 +1,637 @@
|
||||
unit utetris;
|
||||
|
||||
{$mode objfpc}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, Web;
|
||||
|
||||
Const
|
||||
SGameOver = 'Game over!';
|
||||
SPlaying = 'Playing...';
|
||||
|
||||
BlockCount = 7;
|
||||
BlockHigh = BlockCount-1;
|
||||
BlockSize = 4; // Number of positions in a block
|
||||
BoardHeight = 20;
|
||||
BoardWidth = 12;
|
||||
CreatePosX = 4;
|
||||
CreatePosY = 0;
|
||||
BlockColors : Array [0..BlockCount] of String
|
||||
= ('white','#8F3985', '#39A275', '#D28140', '#194A8D', '#8D71B4', '#F0889D', '#DF1C44');
|
||||
|
||||
Type
|
||||
TDirection = (dIdle, dDown, dLeft, dRight);
|
||||
TVerticalCollision = (vcNone,vcBlock,vcWall);
|
||||
|
||||
{$modeswitch advancedrecords}
|
||||
|
||||
TCoordinate = record
|
||||
x,y : Integer;
|
||||
Class function Create(aX,aY : integer) : TCoordinate; static;
|
||||
end;
|
||||
|
||||
TBlock = Array[0..BlockSize-1] of TCoordinate;
|
||||
TBlocks = Array[0..BlockHigh] of TBlock;
|
||||
TBoard = Array[0..BoardWidth-1,0..BoardHeight-1] of Integer; // Colors
|
||||
TCoordinateBoard = Array[0..BoardWidth-1,0..BoardHeight-1] of TCoordinate; // Coordinates of squares
|
||||
|
||||
{ TTetris }
|
||||
|
||||
TTetris = Class(TComponent)
|
||||
private
|
||||
Private
|
||||
FCanvasID: String;
|
||||
FGameOver : Boolean;
|
||||
FCoordinates : TCoordinateBoard;
|
||||
FIncLevelInterval: Integer;
|
||||
FIncLevelScore: Integer;
|
||||
FInterval: Integer;
|
||||
FResetID: String;
|
||||
FTetrisLogo : TJSHTMLImageElement;
|
||||
FCanvas : TJSHTMLCanvasElement;
|
||||
FCtx : TJSCanvasRenderingContext2D;
|
||||
FScore : Integer;
|
||||
FLevel : Integer;
|
||||
FBoard : TBoard;
|
||||
FBlocks : TBlocks;
|
||||
FCurBlock : TBlock;
|
||||
FCurBlockColor : Smallint; // Index in color array
|
||||
FCurrPos : TCoordinate;
|
||||
Fdirection : TDirection;
|
||||
FElScore : TJSHTMLElement;
|
||||
FElLevel : TJSHTMLElement;
|
||||
FElStatus : TJSHTMLElement;
|
||||
FBtnReset : TJSHTMLButtonElement;
|
||||
FMyInterval : NativeInt;
|
||||
function DoResetClick(aEvent: TJSMouseEvent): boolean;
|
||||
procedure SetGameOver(AValue: Boolean);
|
||||
Procedure CheckBlockDown;
|
||||
procedure DrawBlockAt(X, Y, Color: Integer);
|
||||
procedure DrawLevel;
|
||||
Procedure DrawScore;
|
||||
procedure DrawGameStatus;
|
||||
procedure EnableTick;
|
||||
Function HittingTheWall : Boolean;
|
||||
Procedure MoveAllRowsDown(rowsToDelete, startOfDeletion : Integer);
|
||||
function CheckForVerticalCollision(aDirection: TDirection; aBlock: TBlock): TVerticalCollision;
|
||||
Function CheckForHorizontalCollision (aDirection: TDirection; aBlock: TBlock): Boolean;
|
||||
function CheckForCompletedRows : Boolean;
|
||||
Procedure CreateCoordArray;
|
||||
procedure RecalcScore(aRows: integer);
|
||||
procedure SetLevel(AValue: Integer);
|
||||
procedure SetScore(AValue: Integer);
|
||||
Procedure SetupTetris;
|
||||
Procedure DrawBlock;
|
||||
Procedure CreateBlocks;
|
||||
Procedure CreateBlock;
|
||||
Procedure DeleteBlock;
|
||||
function MoveBlockDown: Boolean;
|
||||
Procedure DropBlock;
|
||||
Procedure RotateBlock;
|
||||
Procedure ClearBoard;
|
||||
function DrawTetrisLogo(e : TEventListenerEvent) : Boolean;
|
||||
function HandleKeyPress(k : TJSKeyBoardEvent) : Boolean;
|
||||
Property GameOver : Boolean Read FGameOver Write SetGameOver;
|
||||
Public
|
||||
Constructor Create(aOwner : TComponent); override;
|
||||
Procedure Start;
|
||||
// Reset button ID
|
||||
Property ResetID : String Read FResetID Write FResetID;
|
||||
// our canvas ID
|
||||
Property CanvasID : String Read FCanvasID Write FCanvasID;
|
||||
Property Canvas : TJSHTMLCanvasElement Read FCanvas;
|
||||
Property Ctx : TJSCanvasRenderingContext2D Read FCTX;
|
||||
Property Score : Integer Read FScore Write SetScore;
|
||||
Property Level : Integer Read FLevel Write SetLevel;
|
||||
Property Board : TBoard Read FBoard Write FBoard;
|
||||
Property Stopped : TBoard Read FBoard Write FBoard;
|
||||
Property Blocks : TBlocks Read FBlocks;
|
||||
Property Coordinates : TCoordinateBoard Read FCoordinates;
|
||||
Property Interval : Integer Read FInterval Write FInterval;
|
||||
Property IncLevelScore : Integer Read FIncLevelScore Write FIncLevelScore;
|
||||
Property IncLevelInterval : Integer read FIncLevelInterval write FIncLevelInterval;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
Class function TCoordinate.Create(aX,aY : integer) : TCoordinate;
|
||||
|
||||
begin
|
||||
Result.X:=aX;
|
||||
Result.Y:=aY;
|
||||
end;
|
||||
|
||||
procedure TTetris.CreateCoordArray;
|
||||
|
||||
Const
|
||||
XStart = 11;
|
||||
XStep = 23;
|
||||
YStart = 9;
|
||||
YStep = 23;
|
||||
|
||||
Var
|
||||
x,y,i,j : Integer;
|
||||
|
||||
begin
|
||||
i:=0;
|
||||
j:=0;
|
||||
X:=XStart;
|
||||
For I:=0 to BoardWidth-1 do
|
||||
begin
|
||||
Y:=YStart;
|
||||
For J:=0 to BoardHeight-1 do
|
||||
begin
|
||||
FCoordinates[I,J]:=TCoordinate.Create(X,Y);
|
||||
Y:=Y+YStep;
|
||||
end;
|
||||
X:=X+XStep;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TTetris.SetupTetris;
|
||||
|
||||
begin
|
||||
if FCanvasID='' then
|
||||
FCanvasID:='my-canvas';
|
||||
if FResetID='' then
|
||||
FResetID:='btn-reset';
|
||||
FCanvas:=TJSHTMLCanvasElement(Document.getElementById(FCanvasID));
|
||||
FElScore:=TJSHTMLCanvasElement(Document.getElementById('score'));
|
||||
FElLevel:=TJSHTMLCanvasElement(Document.getElementById('level'));
|
||||
FElStatus:=TJSHTMLCanvasElement(Document.getElementById('status'));
|
||||
FBtnReset:=TJSHTMLButtonElement(Document.getElementById(FResetID));
|
||||
if Assigned(FBtnReset) then
|
||||
FBtnReset.OnClick:=@DoResetClick;
|
||||
FCtx:=TJSCanvasRenderingContext2D(FCanvas.getContext('2d'));
|
||||
FCanvas.width := Round(FCanvas.OffsetWidth);
|
||||
FCanvas.height := Round(FCanvas.OffsetHeight);
|
||||
|
||||
// ctx.scale(2, 2);
|
||||
ctx.fillStyle := 'white';
|
||||
ctx.fillRect(0, 0, canvas.width, canvas.height);
|
||||
ctx.strokeStyle := 'grey';
|
||||
ctx.strokeRect(8, 8, 280, 462);
|
||||
document.onkeydown:=@HandleKeyPress;
|
||||
end;
|
||||
|
||||
procedure TTetris.DrawBlock;
|
||||
|
||||
Var
|
||||
i,X,Y : Integer;
|
||||
|
||||
begin
|
||||
for i:=0 to 3 do
|
||||
begin
|
||||
x:=FCurBlock[i].x + FCurrPos.X;
|
||||
y:=FCurBlock[i].y + FCurrPos.Y;
|
||||
DrawBlockAt(X,Y,FCurBlockColor);
|
||||
end;
|
||||
end;
|
||||
|
||||
function TTetris.DrawTetrisLogo(e : TEventListenerEvent) : Boolean;
|
||||
|
||||
begin
|
||||
if (e=Nil) or (FCTx=Nil) then exit;
|
||||
|
||||
Fctx.drawImage(Ftetrislogo, 300, 8, 161, 54);
|
||||
Result:=False;
|
||||
end;
|
||||
|
||||
function TTetris.HandleKeyPress(k: TJSKeyBoardEvent) : Boolean;
|
||||
|
||||
Procedure DisableKey;
|
||||
|
||||
begin
|
||||
k.cancelBubble:=True;
|
||||
k.preventDefault;
|
||||
end;
|
||||
|
||||
begin
|
||||
Result:=False;
|
||||
if FGameOver then
|
||||
exit;
|
||||
if (k.Code = TJSKeyNames.ArrowLeft) then
|
||||
begin
|
||||
DisableKey;
|
||||
Fdirection:=dLEFT;
|
||||
if (HittingTheWall() or checkForHorizontalCollision(dLeft,FCurBlock)) then
|
||||
exit(True);
|
||||
DeleteBlock();
|
||||
Dec(FCurrPos.X);
|
||||
DrawBlock();
|
||||
end
|
||||
else if (k.Code = TJSKeyNames.ArrowRight) then
|
||||
begin
|
||||
DisableKey;
|
||||
Fdirection:=dRIGHT;
|
||||
if (HittingTheWall() or checkForHorizontalCollision(dRight,FCurBlock)) then
|
||||
exit(True);
|
||||
DeleteBlock();
|
||||
inc(FCurrPos.X);
|
||||
DrawBlock();
|
||||
end
|
||||
else if (k.Code = TJSKeyNames.ArrowDown) then
|
||||
begin
|
||||
DisableKey;
|
||||
MoveBlockDown();
|
||||
end
|
||||
else if (k.Code = TJSKeyNames.ArrowUp) then
|
||||
begin
|
||||
DisableKey;
|
||||
RotateBlock();
|
||||
end
|
||||
else if (k.Code = TJSKeyNames.Space) then
|
||||
begin
|
||||
DisableKey;
|
||||
DropBlock();
|
||||
end;
|
||||
end;
|
||||
|
||||
constructor TTetris.Create(aOwner: TComponent);
|
||||
|
||||
begin
|
||||
inherited Create(aOwner);
|
||||
CreateBlocks();
|
||||
CreateCoordArray();
|
||||
FLevel:=1;
|
||||
FScore:=0;
|
||||
FInterval:=1000;
|
||||
IncLevelScore:=100;
|
||||
end;
|
||||
|
||||
function TTetris.MoveBlockDown: Boolean;
|
||||
|
||||
Var
|
||||
i,x,y : Integer;
|
||||
coll : TVerticalCollision;
|
||||
|
||||
Procedure ShiftBlockDown;
|
||||
|
||||
begin
|
||||
DeleteBlock;
|
||||
Inc(FCurrPos.Y);
|
||||
DrawBlock;
|
||||
end;
|
||||
|
||||
begin
|
||||
Result:=False;
|
||||
Fdirection:=dDOWN;
|
||||
Coll:=CheckForVerticalCollision(FDirection,FCurBlock);
|
||||
Result:=Coll=vcNone;
|
||||
if Result then
|
||||
ShiftBlockDown
|
||||
else
|
||||
begin
|
||||
if Coll<>vcWall then
|
||||
ShiftBlockDown;
|
||||
FGameOver:=(FCurrPos.Y<=2);
|
||||
if FGameOver then
|
||||
DrawGameStatus
|
||||
else
|
||||
begin
|
||||
for I:=0 to BlockSize-1 do
|
||||
begin
|
||||
x:=FCurBlock[i].x + FCurrPos.X;
|
||||
y:=FCurBlock[i].y + FCurrPos.Y;
|
||||
FBoard[x,y]:=FCurBlockColor;
|
||||
end;
|
||||
CheckForCompletedRows();
|
||||
CreateBlock();
|
||||
FDirection:=dIdle;
|
||||
FCurrPos.X:=4;
|
||||
FCurrPos.Y:=0;
|
||||
DrawBlock();
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTetris.DropBlock;
|
||||
begin
|
||||
While MoveBlockDown do;
|
||||
end;
|
||||
|
||||
function TTetris.HittingTheWall : Boolean;
|
||||
|
||||
Var
|
||||
NewX,I : Integer;
|
||||
|
||||
begin
|
||||
Result:=False;
|
||||
I:=0;
|
||||
While (I<BlockSize) and Not Result do
|
||||
begin
|
||||
newX:=FCurBlock[i].X + FCurrPos.X;
|
||||
Result:=((newX <= 0) and (Fdirection = dLEFT)) or
|
||||
((newX >= 11) and (Fdirection = dRIGHT));
|
||||
Inc(I);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTetris.DrawGameStatus;
|
||||
|
||||
Var
|
||||
S : String;
|
||||
|
||||
begin
|
||||
if FGameOver then
|
||||
S:=SGameOver
|
||||
else
|
||||
S:=SPlaying;
|
||||
FElStatus.InnerText:=S
|
||||
end;
|
||||
|
||||
procedure TTetris.DrawScore;
|
||||
|
||||
begin
|
||||
if Assigned(FElScore) then
|
||||
FElScore.InnerText:=IntToStr(FScore);
|
||||
end;
|
||||
|
||||
procedure TTetris.DrawLevel;
|
||||
|
||||
begin
|
||||
if Assigned(FElLevel) then
|
||||
FElLevel.InnerText:=IntToStr(Flevel);
|
||||
end;
|
||||
|
||||
|
||||
function TTetris.CheckForVerticalCollision(aDirection : TDirection; aBlock : TBlock): TVerticalCollision;
|
||||
|
||||
Var
|
||||
X,Y,I : integer;
|
||||
|
||||
begin
|
||||
Result:=vcNone;
|
||||
I:=0;
|
||||
While (I<BlockSize) and (Result=vcNone) do
|
||||
begin
|
||||
x:=aBlock[i].x + FCurrPos.X;
|
||||
y:=aBlock[i].y + FCurrPos.Y;
|
||||
if (aDirection = dDOWN) then
|
||||
inc(Y);
|
||||
if FBoard[x,y+1]>0 then
|
||||
Result:=vcBlock
|
||||
else if (Y>=20) then
|
||||
Result:=vcWall;
|
||||
inc(I);
|
||||
end;
|
||||
end;
|
||||
|
||||
function TTetris.CheckForHorizontalCollision(aDirection: TDirection; aBlock: TBlock): Boolean;
|
||||
|
||||
Var
|
||||
i, X,y : Integer;
|
||||
begin
|
||||
Result:=False;
|
||||
I:=0;
|
||||
While (I<BlockSize) and Not Result do
|
||||
begin
|
||||
x:=aBlock[i].x + FCurrPos.X;
|
||||
y:=aBlock[i].y + FCurrPos.Y;
|
||||
if (adirection = dLEFT) then
|
||||
Dec(x)
|
||||
else if (adirection = dRIGHT) then
|
||||
Inc(x);
|
||||
Result:=FBoard[x,y]>0;
|
||||
Inc(i);
|
||||
end;
|
||||
end;
|
||||
|
||||
function TTetris.CheckForCompletedRows : Boolean;
|
||||
|
||||
Var
|
||||
i,x,y,rowsToDelete, startOfDeletion: Integer;
|
||||
|
||||
begin
|
||||
Result:=False;
|
||||
rowsToDelete:=0;
|
||||
startOfDeletion:=0;
|
||||
y:=0;
|
||||
While Y<BoardHeight do
|
||||
begin
|
||||
Result:=true;
|
||||
X:=0;
|
||||
While (X<BoardWidth) and Result do
|
||||
begin
|
||||
Result:=FBoard[X,Y]>0;
|
||||
Inc(X);
|
||||
end;
|
||||
if (Result) then
|
||||
begin
|
||||
if (StartOfDeletion = 0) then
|
||||
startOfDeletion:=y;
|
||||
Inc(rowsToDelete);
|
||||
for I:=0 to BoardWidth-1 do
|
||||
begin
|
||||
FBoard[i,y]:=0;
|
||||
DrawBlockAt(i,y,0);
|
||||
end
|
||||
end;
|
||||
Inc(Y);
|
||||
end;
|
||||
if (RowsToDelete > 0) then
|
||||
begin
|
||||
MoveAllRowsDown(rowsToDelete, startOfDeletion);
|
||||
RecalcScore(rowsToDelete);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTetris.RecalcScore(aRows : integer);
|
||||
|
||||
Var
|
||||
newLevel : Integer;
|
||||
|
||||
begin
|
||||
Inc(FScore,10*aRows);
|
||||
DrawScore;
|
||||
// Check if we need to increase the level.
|
||||
// We cannot use = since score could go from 90 to 110 if 2 rows are deleted
|
||||
newLevel:=1+(FScore div FIncLevelScore);
|
||||
if (NewLevel>FLevel) then
|
||||
begin
|
||||
FLevel:=NewLevel;
|
||||
FInterval:=FInterval-FIncLevelInterval;
|
||||
EnableTick;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTetris.SetLevel(AValue: Integer);
|
||||
begin
|
||||
if FLevel=AValue then Exit;
|
||||
FLevel:=AValue;
|
||||
DrawLevel;
|
||||
end;
|
||||
|
||||
procedure TTetris.SetScore(AValue: Integer);
|
||||
begin
|
||||
if FScore=AValue then Exit;
|
||||
FScore:=AValue;
|
||||
DrawScore;
|
||||
end;
|
||||
|
||||
procedure TTetris.DrawBlockAt(X,Y,Color : Integer);
|
||||
|
||||
Var
|
||||
Coord : TCoordinate;
|
||||
|
||||
begin
|
||||
coord:=coordinates[x,y];
|
||||
ctx.fillStyle:=BlockColors[Color];
|
||||
ctx.fillRect(coord.X, coord.Y, 21, 21);
|
||||
end;
|
||||
|
||||
procedure TTetris.MoveAllRowsDown(rowsToDelete, startOfDeletion: Integer);
|
||||
|
||||
Var
|
||||
I,x,y,Dest : Integer;
|
||||
|
||||
begin
|
||||
for i:=StartOfDeletion - 1 downto 0 do
|
||||
for X:=0 to BoardWidth-1 do
|
||||
begin
|
||||
Y:=I+RowsToDelete;
|
||||
Dest:=FBoard[x,i];
|
||||
FBoard[x,y]:=Dest;
|
||||
DrawBlockAt(X,Y,Dest);
|
||||
FBoard[x,i]:=0;
|
||||
DrawBlockAt(X,I,0);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTetris.DeleteBlock;
|
||||
|
||||
var
|
||||
I,X,Y : integer;
|
||||
|
||||
begin
|
||||
For I:=0 to BlockSize-1 do
|
||||
begin
|
||||
x:=FCurBlock[i].X + FCurrPos.X;
|
||||
y:=FCurBlock[i].Y + FCurrPos.Y;
|
||||
FBoard[x,y]:=0;
|
||||
DrawBlockAt(X,Y,0);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTetris.CreateBlocks;
|
||||
|
||||
function co (x,y : Integer) : TCoordinate;
|
||||
begin
|
||||
Result:=TCoordinate.Create(X,Y);
|
||||
end;
|
||||
|
||||
begin
|
||||
FBlocks[0]:=[co(1,0), co(0,1), co(1,1), co(2,1)]; // T
|
||||
FBlocks[1]:=[co(0,0), co(1,0), co(2,0), co(3,0)]; // I
|
||||
FBlocks[2]:=[co(0,0), co(0,1), co(1,1), co(2,1)]; // J
|
||||
FBlocks[3]:=[co(0,0), co(1,0), co(0,1), co(1,1)]; // square
|
||||
FBlocks[4]:=[co(2,0), co(0,1), co(1,1), co(2,1)]; // L
|
||||
FBlocks[5]:=[co(1,0), co(2,0), co(0,1), co(1,1)]; // S
|
||||
FBlocks[6]:=[co(0,0), co(1,0), co(1,1), co(2,1)]; // Z
|
||||
end;
|
||||
|
||||
procedure TTetris.CreateBlock;
|
||||
|
||||
Var
|
||||
rnd : Integer;
|
||||
|
||||
begin
|
||||
RND:=Random(BlockCount);
|
||||
FCurBlock:=FBlocks[RND];
|
||||
FCurBlockColor:=RND+1; // 0 is white
|
||||
FCurrPos.X:=CreatePosX;
|
||||
FCurrPos.Y:=CreatePosY;
|
||||
end;
|
||||
|
||||
|
||||
procedure TTetris.RotateBlock;
|
||||
|
||||
Var
|
||||
lBlock,newBlock:TBlock;
|
||||
x,y,i,maxX : Integer;
|
||||
|
||||
begin
|
||||
lBlock:=FCurBlock;
|
||||
maxX:=0;
|
||||
for I:=0 to BlockSize-1 do
|
||||
if lBlock[i].x>MaxX then
|
||||
MaxX:=lBlock[i].x;
|
||||
for I:=0 to BlockSize-1 do
|
||||
begin
|
||||
x:=lBlock[i].x;
|
||||
y:=lBlock[i].y;
|
||||
newBlock[i].X:=maxX-y;
|
||||
newBlock[i].Y:=x;
|
||||
end;
|
||||
// It can be that because of rotation, the block goes out of the board area or collisions.
|
||||
// In that case we forbid rotating
|
||||
// In fact we could try to reposition the block both horizontally and vertically:
|
||||
if (CheckForVerticalCollision(dIdle,NewBlock)=vcNone)
|
||||
and not CheckForHorizontalCollision(dIdle,NewBlock) then
|
||||
begin
|
||||
DeleteBlock();
|
||||
FCurBlock:=newBlock;
|
||||
DrawBlock();
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTetris.ClearBoard;
|
||||
|
||||
Var
|
||||
X,Y : integer;
|
||||
|
||||
begin
|
||||
For X:=0 to BoardWidth-1 do
|
||||
for Y:=0 to BoardHeight-1 do
|
||||
begin
|
||||
FBoard[X,Y]:=0;
|
||||
DrawBlockAt(X,Y,0);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTetris.Start;
|
||||
|
||||
begin
|
||||
GameOver:=False;
|
||||
Level:=1;
|
||||
Score:=0;
|
||||
SetupTetris;
|
||||
ClearBoard;
|
||||
CreateBlock();
|
||||
DrawBlock();
|
||||
EnableTick;
|
||||
end;
|
||||
|
||||
function TTetris.DoResetClick(aEvent: TJSMouseEvent): boolean;
|
||||
begin
|
||||
FInterval:=1000;
|
||||
Start;
|
||||
end;
|
||||
|
||||
procedure TTetris.SetGameOver(AValue: Boolean);
|
||||
begin
|
||||
if FGameOver=AValue then Exit;
|
||||
FGameOver:=AValue;
|
||||
DrawGameStatus;
|
||||
end;
|
||||
|
||||
procedure TTetris.CheckBlockDown;
|
||||
|
||||
begin
|
||||
If Not FGameOver then
|
||||
MoveBlockDown;
|
||||
end;
|
||||
|
||||
procedure TTetris.EnableTick;
|
||||
|
||||
begin
|
||||
if FMyInterval>0 then
|
||||
window.clearInterval(FMyInterval);
|
||||
FMyInterval:=window.setInterval(@CheckBlockDown,FInterval);
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
Loading…
Reference in New Issue
Block a user