Thanks to Dirk Zoller for giving us Tetris for Terminals.
Tested ok with gForth on Mac OSX 10.4.5 terminal. Note: kForth uses NOT while gForth uses 0= instead. Review d<> for the correkt version.
\
\ tt.pfe Tetris for terminals, redone in ANSI-Forth.
\ Written 05Apr94 by Dirk Uwe Zoller,
\ e-mail duz@roxi.rz.fht-mannheim.de.
\ Look&feel stolen from Mike Taylor's "TETRIS FOR TERMINALS"
\
\ Please copy and share this program, modify it for your system
\ and improve it as you like. But don't remove this notice.
\
\ Thank you.
\
only forth also definitions
s" forget-tt" drop 1- find nip [if] forget-tt [then] marker forget-tt
vocabulary tetris tetris also definitions
decimal
\ Variables, constants
bl bl 2constant empty \ an empty position
variable wiping \ if true: wipe brick, else draw brick
2 constant col0 \ position of the pit
0 constant row0
10 constant wide \ size of pit in brick positions
20 constant deep
char J value left-key \ customize if you don't like them
char K value rot-key
char L value right-key
bl value drop-key
char P value pause-key
12 value refresh-key
char Q value quit-key
variable score
variable pieces
variable levels
variable delay
variable brow \ where the brick is
variable bcol
\ stupid random number generator
variable seed
: randomize time&date + + + + + seed ! ;
: random \ max --- n ; return random number < max
seed @ 13 * [ hex ] 07FFF [ decimal ] and
dup seed ! swap mod ;
\ Access pairs of characters in memory:
: 2c@ dup 1+ c@ swap c@ ;
: 2c! dup >r c! r> 1+ c! ;
\ : d<> d= not ; \ kForth
: d<> d= 0= ; \ gForth: use 0= instead of NOT.
\ Drawing primitives:
: 2emit emit emit ;
: position \ row col --- ; cursor to the position in the pit
2* col0 + swap row0 + at-xy ;
: stone \ c1 c2 --- ; draw or undraw these two characters
wiping @ if 2drop 2 spaces else 2emit then ;
\ Define the pit where bricks fall into:
: def-pit create wide deep * 2* allot
does> rot wide * rot + 2* + ;
def-pit pit
: empty-pit deep 0 do wide 0 do empty j i pit 2c!
loop loop ;
\ Displaying:
: draw-bottom \ --- ; redraw the bottom of the pit
deep -1 position
[char] + dup stone
wide 0 do [char] = dup stone loop
[char] + dup stone ;
: draw-frame \ --- ; draw the border of the pit
deep 0 do
i -1 position [char] | dup stone
i wide position [char] | dup stone
loop draw-bottom ;
: bottom-msg \ addr cnt --- ; output a message in the bottom of the pit
deep over 2/ wide swap - 2/ position type ;
: draw-line \ line ---
dup 0 position wide 0 do dup i pit 2c@ 2emit loop drop ;
: draw-pit \ --- ; draw the contents of the pit
deep 0 do i draw-line loop ;
: show-key \ char --- ; visualization of that character
dup bl <
if [char] @ or [char] ^ emit emit space
else [char] ` emit emit [char] ' emit
then ;
: show-help \ --- ; display some explanations
30 1 at-xy ." ***** T E T R I S *****"
30 2 at-xy ." ======================="
30 4 at-xy ." Use keys:"
32 5 at-xy left-key show-key ." Move left"
32 6 at-xy rot-key show-key ." Rotate"
32 7 at-xy right-key show-key ." Move right"
32 8 at-xy drop-key show-key ." Drop"
32 9 at-xy pause-key show-key ." Pause"
32 10 at-xy refresh-key show-key ." Refresh"
32 11 at-xy quit-key show-key ." Quit"
32 13 at-xy ." -> "
30 16 at-xy ." Score:"
30 17 at-xy ." Pieces:"
30 18 at-xy ." Levels:"
0 22 at-xy ." ==== This program was written 1994 in pure dpANS Forth by Dirk Uwe Zoller ===="
0 23 at-xy ." =================== Copy it, port it, play it, enjoy it! =====================" ;
: update-score \ --- ; display current score
38 16 at-xy score @ 3 .r
38 17 at-xy pieces @ 3 .r
38 18 at-xy levels @ 3 .r ;
: refresh \ --- ; redraw everything on screen
page draw-frame draw-pit show-help update-score ;
\ Define shapes of bricks:
: def-brick create 4 0 do
' execute 0 do dup i chars + c@ c, loop drop
refill drop
loop
does> rot 4 * rot + 2* + ;
def-brick brick1 s" "
s" ###### "
s" ## "
s" "
def-brick brick2 s" "
s" <><><><>"
s" "
s" "
def-brick brick3 s" "
s" {}{}{}"
s" {} "
s" "
def-brick brick4 s" "
s" ()()() "
s" () "
s" "
def-brick brick5 s" "
s" [][] "
s" [][] "
s" "
def-brick brick6 s" "
s" @@@@ "
s" @@@@ "
s" "
def-brick brick7 s" "
s" %%%% "
s" %%%% "
s" "
\ this brick is actually in use:
def-brick brick s" "
s" "
s" "
s" "
def-brick scratch s" "
s" "
s" "
s" "
create bricks ' brick1 , ' brick2 , ' brick3 , ' brick4 ,
' brick5 , ' brick6 , ' brick7 ,
create brick-val 1 c, 2 c, 3 c, 3 c, 4 c, 5 c, 5 c,
: is-brick \ brick --- ; activate a shape of brick
>body ['] brick >body 32 cmove ;
: new-brick \ --- ; select a new brick by random, count it
1 pieces +! 7 random
bricks over cells + @ is-brick
brick-val swap chars + c@ score +! ;
: rotleft 4 0 do 4 0 do
j i brick 2c@ 3 i - j scratch 2c!
loop loop
['] scratch is-brick ;
: rotright 4 0 do 4 0 do
j i brick 2c@ i 3 j - scratch 2c!
loop loop
['] scratch is-brick ;
: draw-brick \ row col ---
4 0 do 4 0 do
j i brick 2c@ empty d<>
if over j + over i + position
j i brick 2c@ stone
then
loop loop 2drop ;
: show-brick wiping off draw-brick ;
: hide-brick wiping on draw-brick ;
: put-brick \ row col --- ; put the brick into the pit
4 0 do 4 0 do
j i brick 2c@ empty d<>
if over j + over i + pit
j i brick 2c@ rot 2c!
then
loop loop 2drop ;
: remove-brick \ row col --- ; remove the brick from that position
4 0 do 4 0 do
j i brick 2c@ empty d<>
if over j + over i + pit empty rot 2c! then
loop loop 2drop ;
: test-brick \ row col --- flag ; could the brick be there?
4 0 do 4 0 do
j i brick 2c@ empty d<>
if over j + over i +
over dup 0< swap deep >= or
over dup 0< swap wide >= or
2swap pit 2c@ empty d<>
or or if unloop unloop 2drop false exit then
then
loop loop 2drop true ;
: move-brick \ rows cols --- flag ; try to move the brick
brow @ bcol @ remove-brick
swap brow @ + swap bcol @ + 2dup test-brick
if brow @ bcol @ hide-brick
2dup bcol ! brow ! 2dup show-brick put-brick true
else 2drop brow @ bcol @ put-brick false
then ;
: rotate-brick \ flag --- flag ; left/right, success
brow @ bcol @ remove-brick
dup if rotright else rotleft then
brow @ bcol @ test-brick
over if rotleft else rotright then
if brow @ bcol @ hide-brick
if rotright else rotleft then
brow @ bcol @ put-brick
brow @ bcol @ show-brick true
else drop false then ;
: insert-brick \ row col --- flag ; introduce a new brick
2dup test-brick
if 2dup bcol ! brow !
2dup put-brick draw-brick true
else false then ;
: drop-brick \ --- ; move brick down fast
begin 1 0 move-brick 0= until ;
: move-line \ from to ---
over 0 pit over 0 pit wide 2* cmove draw-line
dup 0 pit wide 2* blank draw-line ;
: line-full \ line-no --- flag
true wide 0
do over i pit 2c@ empty d=
if drop false leave then
loop nip ;
: remove-lines \ ---
deep deep
begin
swap
begin 1- dup 0< if 2drop exit then dup line-full
while 1 levels +! 10 score +! repeat
swap 1-
2dup <> if 2dup move-line then
again ;
: to-upper \ char --- char ; convert to upper case
dup [char] a >= over [char] z <= and if bl - then ;
: interaction \ --- flag
case key to-upper
left-key of 0 -1 move-brick drop endof
right-key of 0 1 move-brick drop endof
rot-key of 0 rotate-brick drop endof
drop-key of drop-brick endof
pause-key of S" paused " bottom-msg key drop
draw-bottom endof
refresh-key of refresh endof
quit-key of false exit endof
endcase true ;
: initialize \ --- ; prepare for playing
randomize empty-pit refresh
0 score ! 0 pieces ! 0 levels ! 100 delay ! ;
: adjust-delay \ --- ; make it faster with increasing score
levels @
dup 50 < if 100 over - else
dup 100 < if 62 over 4 / - else
dup 500 < if 31 over 16 / - else 0 then then then
delay ! drop ;
: play-game \ --- ; play one tetris game
begin
new-brick
-1 3 insert-brick
while
begin 4 0
do 35 13 at-xy
delay @ ms key?
if interaction 0=
if unloop exit then
then
loop
1 0 move-brick 0=
until
remove-lines
update-score
adjust-delay
repeat ;
forth definitions
: tt \ --- ; play the tetris game
initialize
s" Press any key " bottom-msg key drop draw-bottom
begin
play-game
s" Again? " bottom-msg key to-upper [char] Y =
while initialize repeat
0 23 at-xy cr ;
only forth also definitions