Simba Code:
program Tetris;
(*
A hacked together tetris game that uses the builtin debug image.
Requires Simba 1.2-RC5 or later.
*)
const
//** CONFIGUREATION **//
TURN_RIGHT = VK_D;
TURN_LEFT = VK_A;
MOVE_LEFT = VK_LEFT;
MOVE_RIGHT = VK_RIGHT;
MOVE_DOWN = VK_DOWN;
DROP_DOWN = VK_SPACE;
RESTART_GAME = VK_F5;
PAUSE_GAME = VK_P;
START_LEVEL = 1;
//special conf:
GAME_WIDTH = 10;
GAME_HEIGHT = 20;
BASE_TICK = 700;
POINTSIZE = 24;
//----------------------------------------------------------------------------\\
//----------------------------------------------------------------------------\\
type
TFace = (f0,f1,f2,f3);
TState = (stRunning, stCompleted);
TBrick = record
id: Int32;
pos: TPoint;
face: TFace;
end;
TBrickArray = array of TBrick;
TTetris = record
Width,Height:Int32;
Bounds:TBox;
Board:TMufasaBitmap;
Active, Original, Next:TBrick;
State:TState;
Score:Int32;
Level:Int32;
Tick:Int32;
CollapseCount:Int32;
end;
const
GLOB_BRICKS:T2DPointArray = [
[[0,0],[0,1],[1,0],[2,0]], // :''
[[0,0],[1,0],[2,0],[3,0]], // ....
[[0,0],[1,0],[2,0],[1,1]], // ':'
[[1,0],[2,0],[0,1],[1,1]], // .:'
[[0,0],[1,0],[1,1],[2,1]], // ':.
[[0,0],[1,0],[0,1],[1,1]], // ::
[[0,0],[1,0],[2,0],[2,1]] // '':
];
GLOB_COLORS:TIntegerArray = [
$3388FF, //orange
$FFCC33, //cyan
$FF33BB, //purple
$33FF77, //green
$3333FF, //red / pink
$33DDFF, //yellow
$FF9000 //blue
];
BACKGROUND = $333333;
function TBrick.GetBrickTPA(): TPointArray; constref;
begin
Result := GLOB_BRICKS[self.id];
case self.face of
f0: Result := Copy(Result);
f1: Result := RotatePoints(Result, radians(90), 1,0);
f2: Result := RotatePoints(Result, radians(180), 1,0);
f3: Result := RotatePoints(Result, radians(270), 1,0);
end;
OffsetTPA(Result, Self.pos);
end;
procedure TTetris.FillBox(x,y:Int32; color:Int32=BACKGROUND);
var
h,s,l:Extended;
begin
x *= POINTSIZE;
y *= POINTSIZE;
try
self.Board.DrawTPA(TPAFromBox([x,y,x+POINTSIZE-2,y+POINTSIZE-2]), color);
if color <> BACKGROUND then
begin
ColorToHSL(color, H,S,L);
color := HSLToColor(H,S-15,L-15);
self.Board.DrawTPA(EdgeFromBox([x,y,x+POINTSIZE-2,y+POINTSIZE-2]), color);
end;
except
end;
end;
function TTetris.IsFilled(x,y:Int32): Boolean;
begin
Result := (y > 0) and (self.board.GetPixel(x * POINTSIZE, y * POINTSIZE) <> BACKGROUND);
end;
procedure TTetris.DrawBrick(brick:TBrick);
var pt:TPoint;
begin
for pt in brick.GetBrickTPA() do
self.FillBox(pt.x,pt.y, GLOB_COLORS[brick.id]);
end;
procedure TTetris.UndrawBrick(brick:TBrick);
var pt:TPoint;
begin
for pt in brick.GetBrickTPA() do
self.FillBox(pt.x,pt.y);
end;
function TTetris.Collides(): Boolean;
var
pt:TPoint;
begin
for pt in active.GetBrickTPA() do
if (not(InRange(pt.x, Bounds.x1, Bounds.x2) and InRange(pt.y, Bounds.y1, Bounds.y2))) or
self.IsFilled(pt.x,pt.y) then
Exit(True);
end;
function TTetris.TryRotateCW(): Boolean;
var
pt:TPoint;
oldface:TFace;
begin
Result := True;
self.UndrawBrick(self.Active);
oldface := active.face;
if active.face = f3 then active.face := f0
else Inc(active.face);
if self.Collides() then
begin
active.face := oldface;
self.DrawBrick(self.Active);
Result := False;
end;
end;
function TTetris.TryRotateCCW(): Boolean;
var
pt:TPoint;
oldface:TFace;
begin
Result := True;
self.UndrawBrick(self.Active);
oldface := active.face;
if active.face = f0 then active.face := f3
else Dec(active.face);
if self.Collides() then
begin
active.face := oldface;
self.DrawBrick(self.Active);
Result := False;
end;
end;
function TTetris.TryMove(ox,oy:Int32): Boolean;
var
pt:TPoint;
oldpos:TPoint;
begin
Result := True;
self.UndrawBrick(self.Active);
oldpos := active.pos;
active.pos.x += ox;
active.pos.y += oy;
if self.Collides() then
begin
active.pos := oldpos;
self.DrawBrick(self.Active);
Result := False;
end;
end;
procedure TTetris.UpdateBrick();
begin
self.UndrawBrick(Original);
self.DrawBrick(Active);
self.Update();
end;
procedure TTetris.LevelUp();
begin
self.Tick := Ceil(self.Tick*0.75);
if self.Tick < 1 then self.Tick := 1;
self.Level += 1;
self.collapseCount := 0;
end;
procedure TTetris.CheckRows();
var
x,y,counter:Int32;
procedure RemoveRow(row:Int32);
var x,y,color:Int32;
begin
counter += 1;
for y:=row-1 downto 0 do
for x:=0 to Bounds.X2 do
begin
color := self.board.GetPixel(x * POINTSIZE+1, y * POINTSIZE+1);
self.FillBox(x,y);
self.FillBox(x,y+1, color);
end;
end;
begin
for y:=0 to Bounds.Y2 do
begin
for x:=0 to Bounds.X2 do
if not self.IsFilled(x,y) then
break;
if (x = self.Width) then RemoveRow(y);
end;
self.Score += counter*self.Width;
self.collapseCount += counter;
if self.collapseCount >= 10 then self.LevelUp();
end;
procedure TTetris.NewBrick();
begin
self.Original := self.Next;
self.Active := self.Next;
self.Next.pos := Point(self.Width div 2 - 1, -1);
self.Next.face := f0;
self.Next.id := Random(0,High(GLOB_BRICKS));
end;
procedure TTetris.Debug();
var
x:Int32;
pt:TPoint;
brick:TBrick;
procedure _FillBrick(x,y:Int32; size:Int32=15);
begin
for pt in brick.GetBrickTPA() do
begin
pt.x := x+pt.x*size;
pt.y := y+pt.y*size;
self.Board.DrawTPA(TPAFromBox([pt.x,pt.y, pt.x+size-2,pt.y+size-2]), $FFFFFF);
end;
end;
begin
x := self.Width*POINTSIZE + 20;
if self.score = 0 then
begin
self.Board.DrawText('Score:', 'UpChars07', Point(x,20), False, $AAAAAA);
self.Board.DrawText('Level:', 'UpChars07', Point(x,80), False, $AAAAAA);
self.Board.DrawText('Speed:', 'UpChars07', Point(x,140), False, $AAAAAA);
self.Board.DrawText('Next:', 'UpChars07', Point(x,200), False, $AAAAAA);
end;
//clear
self.Board.DrawTPA(TPAFromBox([x,40,Board.GetWidth()-1,60]), 0);
self.Board.DrawTPA(TPAFromBox([x,100,Board.GetWidth()-1,120]), 0);
self.Board.DrawTPA(TPAFromBox([x,160,Board.GetWidth()-1,180]), 0);
self.Board.DrawTPA(TPAFromBox([x,220,Board.GetWidth()-1, 220+50]), 0);
//draw
self.Board.DrawText(ToStr(self.Score), 'SmallChars07', Point(x,40), False, $FFFFFF);
self.Board.DrawText(ToStr(self.Level), 'SmallChars07', Point(x,100), False, $FFFFFF);
self.Board.DrawText(ToStr(Round(BASE_TICK/self.Tick,2)), 'SmallChars07', Point(x,160), False, $FFFFFF);
brick := self.Next;
brick.pos := [0,0];
_FillBrick(x,220,15);
//----
if self.State = stCompleted then
begin
ClearDebug();
WriteLn('Game over!!');
end;
end;
procedure TTetris.RestartGame();
var x,y:Int32;
begin
Self.Tick := 1000;
for x:=0 to Width-1 do
for y:=0 to Height-1 do
Self.FillBox(x,y);
Self.Level := 1;
Self.Tick := BASE_TICK;
for 1 to START_LEVEL-1 do Self.LevelUp();
Self.Score := 0;
Self.State := stRunning;
Self.NewBrick();
Self.Debug();
end;
procedure TTetris.HandleEvent();
var t,t2:UInt64;
begin
t := GetTickCount() + Tick;
while GetTickCount() < t do
begin
self.UpdateBrick();
Original := Active;
t2 := GetTickCount() + 196;
if isKeyDown(TURN_RIGHT) then
begin
TryRotateCW();
while isKeyDown(TURN_RIGHT) and (GetTickCount() < t2) do Wait(2);
end
else if isKeyDown(TURN_LEFT) then
begin
TryRotateCCW();
while isKeyDown(TURN_LEFT) and (GetTickCount() < t2) do Wait(2);
end
else if isKeyDown(MOVE_LEFT) then
begin
TryMove(-1,0);
while isKeyDown(MOVE_LEFT) and (GetTickCount() < t2) do Wait(2);
end
else if isKeyDown(MOVE_RIGHT) then
begin
TryMove(1,0);
while isKeyDown(MOVE_RIGHT) and (GetTickCount() < t2) do Wait(2);
end
else if isKeyDown(MOVE_DOWN) then
begin
while isKeyDown(MOVE_DOWN) and TryMove(0,1) do
begin
self.UpdateBrick();
Wait(4);
end;
end
else if isKeyDown(DROP_DOWN) then
begin
while TryMove(0,1) do
begin
self.UpdateBrick();
Wait(4);
end;
end
else if isKeyDown(RESTART_GAME) then
begin
self.RestartGame();
end
else if isKeyDown(PAUSE_GAME) then
begin
ClearDebug();
WriteLn(self.Score);
WriteLn('Game is paused!');
while isKeyDown(PAUSE_GAME) do Wait(16);
while not isKeyDown(PAUSE_GAME) do Wait(16);
while isKeyDown(PAUSE_GAME) do Wait(16);
ClearDebug();
WriteLn(self.Score);
WriteLn('Game has been resumed!');
end;
Wait(2);
end;
self.UpdateBrick();
end;
function TTetris.Create(AWidth,AHeight:Int32): TTetris; static;
var
x,y:Int32;
begin
Result.Width := AWidth;
Result.Height := AHeight;
Result.Board.Init(client.getMBitmaps);
Result.Board.SetSize(AWidth*POINTSIZE+150, AHeight*POINTSIZE);
Result.Bounds := [0,-3,Result.Width-1,Result.Height-1];
x := AWidth*POINTSIZE;
Result.Board.DrawTPA(TPAFromBox([x,0,x, AHeight*POINTSIZE-1]), $999999);
Result.Level := 1;
Result.Tick := BASE_TICK;
for 1 to START_LEVEL-1 do Result.LevelUp();
for x:=0 to AWidth-1 do
for y:=0 to AHeight-1 do
Result.FillBox(x,y);
end;
procedure TTetris.Display(); constref;
begin
DisplayDebugImgWindow(Self.board.GetWidth,Self.Board.GetHeight);
DrawBitmapDebugImg(Self.Board.GetIndex());
end;
procedure TTetris.Update(); constref;
begin
DrawBitmapDebugImg(Self.Board.GetIndex());
end;
procedure TTetris.Focus(); constref;
{$IFNDEF LINUX}
var proc:TSysProc;
function SetForegroundWindow(HWND:UInt64): LongBool; external 'SetForegroundWindow@User32.dll';
begin
for proc in GetProcesses() do
if proc.Title = 'DebugImgForm' then
SetForegroundWindow(proc.Handle);
end;
{$ELSE}
begin
WriteLn('Click / Focus the debug window manually, starting in 1 second');
Wait(1000);
end;
{$ENDIF}
function TTetris.Run(): Boolean;
begin
self.State := stRunning;
self.Display();
self.Focus();
self.NewBrick();
self.Debug();
while True do
begin
self.HandleEvent();
Original := Active;
if not self.TryMove(0,1) then
begin
self.Score += self.Active.pos.y;
if self.Active.pos.y = -1 then
self.State := stCompleted
else
begin
self.CheckRows();
self.NewBrick();
self.Debug();
Wait(170);
end;
end;
while self.State = stCompleted do
begin
Self.Debug();
self.HandleEvent();
Wait(8);
end;
end;
end;
var
Tetris:TTetris;
tmp:TBrick;
begin
Tetris := TTetris.Create(GAME_WIDTH,GAME_HEIGHT);
Tetris.Run();
end.