And here is a real application.
Text: TheTetrisGame
This program is a port of the "tt.pfe" Tetris, written by Dirk Zoller
for PFE. It is ANSI compliant in the original, and more or less so in
the present version.
Tetris has been ported to Holon by Thomas Beierlein and reworked by
Wolf Wejgaard. Tetris is included with Holon as a working demonstration
program.
Text: TheRules
Bricks of different shapes appear at random and drift down into a
pit. You can move the current brick left or right with the 'left' or
'right' cursor keys, or rotate the brick in 90 degree increments with
the 'up' key. The aim is to build complete lines with no gaps. A
completed line is removed, providing space for more bricks. Bricks and
lines contribute to the score.
The 'down' key lets the brick fall straight down, the space bar
halts the game until you press space again, and 'Q' ends the current
game.
12 constant PitWidth
16 constant PitDepth
Defining word for a pit. Creates the data array and defines the action
of the pit. The pit delivers the address of the element i,j.
: DefinePit
create PitWidth PitDepth * allot
does> rot PitWidth * rot + + ; ( i j -- adr )
Defines the pit.
DefinePit Pit
Upper left corner of the pit.
5 constant PitX0
4 constant PitY0
Sets cursor to position row col in the pit.
: Position ( row col -- )
2* PitX0 + swap PitY0 + xy ;
Background colour.
0 constant Black
Flag Draw?
: 2emit ( c -- )
dup emit emit ;
Draws or undraws two characters with attribute b (=0, if blank)
: Stone ( b -- )
Attribute swap
Draw? over and
if 8 + Black + is Attribute 178 2emit
else drop Black is Attribute 2 spaces
then is Attribute ;
Fills pit array with zeroes.
: EmptyPit
0 0 Pit PitWidth PitDepth * erase ;
: Wall
177 2emit ;
Draws the bottom of the pit.
: DrawBottom
PitDepth -1 Position
PitWidth 2+ 0 do Wall loop ;
Draws the border of the pit.
: DrawFrame
PitDepth 0
do i -1 Position Wall i PitWidth Position Wall loop
DrawBottom ;
: DrawLine ( line -- )
dup 0 Position
PitWidth 0 do dup i Pit c@ stone loop drop ;
Draws the contents of the pit.
: DrawPit
PitDepth 0 do i DrawLine loop ;
: ShowHelp
50 1 xy ." ***** T E T R I S *****"
50 2 xy ." ======================="
50 5 xy ." left : Move left"
50 6 xy ." right: Move right"
50 7 xy ." up : Rotate"
50 8 xy ." down : Drop"
50 9 xy ." space: Pause"
50 11 xy ." 'Q' : Quit"
3 1 xy ." Score:"
16 1 xy ." Pieces:"
31 1 xy ." Levels:"
;
0 integer Score
0 integer Pieces
0 integer Levels
0 integer Delay
display current score
: UpdateScore
10 1 xy bold Score 3 .r normal
24 1 xy Pieces 3 .r
39 1 xy Levels 3 .r ;
Redraw everything on the screen.
: Refresh
page DrawFrame DrawPit ShowHelp UpdateScore ;
Defining word for bricks.
: Brick:
create 8 0 do c, loop ( 8bytes -- )
does> ;
The shape and the colour of the brick are defined by the numbers <> 0.
1 1 1 0
0 1 0 0 Brick: Brick1
2 2 2 2
0 0 0 0 Brick: Brick2
0 3 3 3
0 3 0 0 Brick: Brick3
4 4 4 0
0 0 4 0 Brick: Brick4
0 5 5 0
0 5 5 0 Brick: Brick5
6 6 0 0
0 6 6 0 Brick: Brick6
0 7 7 0
7 7 0 0 Brick: Brick7
Table of brick execution tokens. Note: ',' is a compiling word of the
host.
create Bricks
' Brick1 , ' Brick2 , ' Brick3 , ' Brick4 ,
' Brick5 , ' Brick6 , ' Brick7 ,
create Scratch 16 allot
Stores byte b in element i,j of the scratch array. Sometimes it is
helpful to note the stack action in stack diagrams.
: scratch! ( b i j -- )
scratch \ -- b i j adr
rot \ -- b j adr i
4 * \ -- b j adr n
rot \ -- b adr n j
+ \ -- b adr n2
+ \ -- b adr2
c! ;
Contains the pattern of the current brick.
create Brick 16 allot
: brick@ ( i j -- b )
brick rot 4 * rot + + c@ ;
The value in "score" for each brick's difficulty.
create BrickValue
1 c, 2 c, 3 c, 3 c, 4 c, 5 c, 5 c,
Inserts the current brick's shape into "brick". xt is the execution
token of a brick word, it is executed and delivers the address of the
brick's data.
: isBrick ( xt -- )
Brick 16 erase
execute ( -- adr )
8 times dup i + c@ Brick 4 + i + c! loop
drop ;
Brick position.
0 integer bRow
0 integer bCol
Leaves a random number smaller than max.
: Random ( max -- u )
time@ + + + swap mod ;
Choose a new brick randomly and add to score.
: NewBrick
1 add Pieces 7 Random
Bricks over cells + @ isBrick
BrickValue swap chars + c@ add Score ;
Rotates current brick left.
: RotateLeft
4 0 do 4 0 do j i brick@ 3 i - j scratch! loop loop
Scratch Brick 16 move ;
Rotates current brick right.
: RotateRight
4 0 do 4 0 do j i brick@ i 3 j - scratch! loop loop
Scratch Brick 16 move ;
Rotates brick according to flag f.
: Rotate ( f -- )
if RotateRight else RotateLeft then ;
: DrawBrick
4 0 do 4 0 do
j i brick@ 0<>
if brow j + bcol i + Position j i brick@ Stone then
loop loop ;
: ShowBrick
set Draw? DrawBrick ;
: HideBrick
clear Draw? DrawBrick ;
Put the brick into the pit.
: PutBrick
4 0 do 4 0 do
j i brick@ 0<>
if brow j + bcol i + Pit j i brick@ swap c! then
loop loop ;
Could the brick be there?
: Brick? ( row col -- f )
4 0 do 4 0 do
j i brick@ 0<>
if over j + over i +
over dup 0< swap PitDepth >= or
over dup 0< swap PitWidth >= or
2swap Pit c@ 0<>
or or if unloop unloop 2drop false exit then
then
loop loop 2drop true ;
Removes the brick from that position.
: RemoveBrick
brow bcol
4 0 do 4 0 do
j i brick@ 0<>
if over j + over i + Pit 0 swap c! then
loop loop
2drop ;
Tries to move the brick.
: MoveBrick? ( rows cols -- f )
RemoveBrick
swap brow + swap bcol +
2dup Brick?
if HideBrick is bCol is bRow
ShowBrick PutBrick true
else 2drop PutBrick false
then ;
f = left/right.
: RotateBrick ( f -- )
brow 0< if drop exit then \ no space yet for rotating
RemoveBrick dup Rotate
brow bcol Brick?
over 0= Rotate
if HideBrick Rotate PutBrick ShowBrick
else drop
then ;
Introduces a new brick.
: InsertBrick? ( row col -- flag )
2dup Brick?
if is bcol is brow PutBrick DrawBrick true
else 2drop false
then ;
Moves the brick down fast.
: DropBrick
begin 1 0 MoveBrick? 0= until ;
: MoveLine ( from to -- )
over 0 Pit over 0 Pit PitWidth move DrawLine
dup 0 Pit PitWidth erase DrawLine ;
Leaves true, if line is filled with bricks.
: LineFull? ( line# - f )
true
PitWidth 0
do over i Pit c@ 0= if drop false leave then loop
nip ;
: RemoveLines
PitDepth dup
begin swap
begin 1- dup 0< if 2drop exit then
dup LineFull?
while 1 add Levels 10 add Score
repeat
swap 1- 2dup <> if 2dup MoveLine then
again ;
Flag End?
Shows the message "adr and waits for a key, leaves key code.
: AskMessage ( "adr -- c )
@xy rot SaveScreen
50 20 xy ." --- " "type ." ---" key
RestoreScreen -rot xy ;
Converts character c1 to uppercase c2.
: >Upper ( c1 -- c2)
dup [char] a >= over [char] z <= and if $20 - then ;
: CharCases ( c -- )
case >Upper
09 of Halt endof \ Tab switches to host in Coroutine
'bl of " paused " AskMessage drop endof
[char] Q of set End? endof
drop endcase ;
: FuncCases ( c -- )
case
75 ( left ) of 0 -1 MoveBrick? drop endof
77 ( right) of 0 1 MoveBrick? drop endof
72 ( up ) of 0 RotateBrick endof
80 ( down ) of DropBrick endof
drop endcase ;
: Interaction ( -- )
key ?dup if CharCases else FuncCases then ;
Prepares for playing.
: Initialize
0 is Score 0 is Pieces 0 is Levels 100 is Delay
emptyPit Refresh clear End? !sp ;
Makes it faster with increasing score.
: AdjustDelay
Levels
dup 50 < if 100 swap -
else dup 100 < if 62 swap 4 / -
else dup 500 < if 31 swap 16 / -
else drop 0
then then then
is Delay ;
User interaction?
: ?Interaction
Delay msec
key? if Interaction then ;
Tests: ... Change the insert method while Tetris runs...
(put the backslash in front of the other line and reload the word).
: StartBrick? ( -- f )
\ NewBrick -1 8 InsertBrick? \ insert in center
NewBrick -1 PitWidth 2/ Random InsertBrick? \ insert randomly
;
Play one Tetris game.
: PlayGame
begin StartBrick?
while begin 4 0 do ?Interaction loop
End? if exit then
1 0 moveBrick? 0=
until
RemoveLines UpdateScore AdjustDelay
repeat ;
This is the final group in the turnkey application.
The final runtime word... Plays the game.
: TetrisGame
Initialize CurOff " Press any key" AskMessage drop
begin PlayGame
" Again? (Y/N)" AskMessage >Upper [char] Y =
while Initialize
repeat
page 50 20 xy ." --- bye (see you later) --- " ;
The Tetrisprogram running as the main task. If you start it from the
host, the host waits for the program to end.
: Tetris
Console TetrisGame ;
Makes Tetris the startword of a turnkey version of the tetris program.
Press Ctl+F7=Turnkey to save the code as file TURNKEY.EXE.
( TheTetris )
Program: Tetris
Use this group during development. Let Tetris run as a task in the
target system, and work on the running program.
Creates the Tetris task.
Task TetrisTask
The task program which is started with the task.
: TaskProgram
Screen TaskKeys TetrisGame ;
Starts the Tetris task.
: StartTetris
make TetrisTask TaskProgram start TetrisTask ;
Stops the task.
: StopTetris
stop TetrisTask ;