view examples_forth/tetris.4 @ 176:6ef317714ae8

mopen in TL/1
author Shinji KONO <kono@ie.u-ryukyu.ac.jp>
date Mon, 15 Apr 2019 00:25:58 +0900
parents 2088fd998865
children
line wrap: on
line source

\
\ tetris.4th	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.
\
\		Changes:
\
\

ONLY FORTH DEFINITIONS
\ S" FORGET-TT" DROP 1 CHARS - FIND NIP [IF] FORGET-TT [THEN]
\ MARKER FORGET-TT

DECIMAL

WORDLIST CONSTANT TETRIS
GET-ORDER TETRIS DUP ROT 2 + SET-ORDER DEFINITIONS


\ 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 on screen
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	0 ." Press any key." CR BEGIN 1+ KEY? UNTIL KEY DROP SEED ! ;

: RANDOM	\ max --- n ; return random number < max
		SEED @ 1103515245 * 12345 + [ 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! ;


: <=		> INVERT ;
: >=		< INVERT ;
: D<>		D= INVERT ;


\ 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* CHARS + ;

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 ANS 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* CHARS + ;

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	FALSE WIPING ! DRAW-BRICK ;
: HIDE-BRICK	TRUE  WIPING ! 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  2DROP 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  [ CHAR A CHAR a - ] LITERAL +  THEN ;

: DISPATCH	\ key --- flag
		CASE  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  BEGIN  KEY KEY? WHILE  DROP  REPEAT
				DISPATCH 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