Dieser Beitrag ist umgezogen in das Forth-ev wiki. Examples in Forth:Tetris for Terminal
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 r c! r> 1+ c! ;
: d d= 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 "
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= or
over dup 0= 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 2dup move-line then
again ;
: to-upper char --- char ; convert to upper case
dup [char] a >= over [char] z
Kommentare (0)
Forth-Gesellschaft e.V.
/article.php/2005042215192196