⚠️ Warning: This is a draft ⚠️

This means it might contain formatting issues, incorrect code, conceptual problems, or other severe issues.

If you want to help to improve and eventually enable this page, please fork RosettaGit's repository and open a merge request on GitHub.

Forth

{{works with|AnsiForth94 |SwiftForth, SPF4, Win32Forth ...}} Console Tetris use ANSI escape sequences


\
\ tt.pfe	Tetris for terminals, redone in ANSI-Forth.
\		Written 05Apr94 by Dirk Uwe Zoller,
\			e-mail [email protected].
\		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

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 ! ;

1 cells 4 = [IF]
$10450405 Constant generator

: rnd  ( -- n )  seed @ generator um* drop 1+ dup seed ! ;

: random ( n -- 0..n-1 )  rnd um* nip ;
[ELSE]
: random	\ max --- n ; return random number < max
		seed @ 13 * [ hex ] 07FFF [ decimal ] and
		dup seed !  swap mod ;
[THEN]

\ Access pairs of characters in memory:

: 2c@		dup 1+ c@ swap c@ ;
: 2c!		dup >r c! r> 1+ c! ;

: d<>		d= 0= ;


\ 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 [char] z 1+ within 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
\ run 
tt