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