File:  [gforth] / gforth / tt.fs
Revision 1.3: download - view: text, annotated - select for diffs
Sat Oct 4 17:33:54 1997 UTC (22 years, 1 month ago) by anton
Branches: MAIN
CVS tags: v0-4-0, HEAD
removed some global keys in gforth.el (bug report from a Debian user)
fixed TO bug hopefully (reported by Michael Vanier <mvanier@bbb.caltech.edu>)

    1: \
    2: \ tt.pfe	Tetris for terminals, redone in ANSI-Forth.
    3: \		Written 05Apr94 by Dirk Uwe Zoller,
    4: \			e-mail duz@roxi.rz.fht-mannheim.de.
    5: \		Look&feel stolen from Mike Taylor's "TETRIS FOR TERMINALS"
    6: \
    7: \		Please copy and share this program, modify it for your system
    8: \		and improve it as you like. But don't remove this notice.
    9: \
   10: \		Thank you.
   11: \
   12: 
   13: only forth also definitions
   14: s" forget-tt" sfind [if] forget-tt [then] marker forget-tt
   15: 
   16: vocabulary tetris  tetris also definitions
   17: 
   18: decimal
   19: 
   20: \ Variables, constants
   21: 
   22: bl bl 2constant empty		\ an empty position
   23: variable wiping			\ if true: wipe brick, else draw brick
   24:  2 constant col0		\ position of the pit
   25:  0 constant row0
   26: 
   27: 10 constant wide		\ size of pit in brick positions
   28: 20 constant deep
   29: 
   30: char J	value left-key		\ customize if you don't like them
   31: char K	value rot-key
   32: char L	value right-key
   33: bl	value drop-key
   34: char P	value pause-key
   35: 12	value refresh-key
   36: char Q	value quit-key
   37: 
   38: variable score
   39: variable pieces
   40: variable levels
   41: variable delay
   42: 
   43: variable brow			\ where the brick is
   44: variable bcol
   45: 
   46: 
   47: \ stupid random number generator
   48: 
   49: variable seed
   50: 
   51: : randomize	time&date + + + + + seed ! ;
   52: 
   53: 1 cells 4 = [IF]
   54: $10450405 Constant generator
   55: 
   56: : rnd  ( -- n )  seed @ generator um* drop 1+ dup seed ! ;
   57: 
   58: : random ( n -- 0..n-1 )  rnd um* nip ;
   59: [ELSE]
   60: : random	\ max --- n ; return random number < max
   61: 		seed @ 13 * [ hex ] 07FFF [ decimal ] and
   62: 		dup seed !  swap mod ;
   63: [THEN]
   64: 
   65: \ Access pairs of characters in memory:
   66: 
   67: : 2c@		dup 1+ c@ swap c@ ;
   68: : 2c!		dup >r c! r> 1+ c! ;
   69: 
   70: : d<>		d= 0= ;
   71: 
   72: 
   73: \ Drawing primitives:
   74: 
   75: : 2emit		emit emit ;
   76: 
   77: : position	\ row col --- ; cursor to the position in the pit
   78: 		2* col0 + swap row0 + at-xy ;
   79: 
   80: : stone		\ c1 c2 --- ; draw or undraw these two characters
   81: 		wiping @ if  2drop 2 spaces  else  2emit  then ;
   82: 
   83: 
   84: \ Define the pit where bricks fall into:
   85: 
   86: : def-pit	create	wide deep * 2* allot
   87: 		does>	rot wide * rot + 2* + ;
   88: 
   89: def-pit pit
   90: 
   91: : empty-pit	deep 0 do wide 0 do  empty j i pit 2c!
   92: 		loop loop ;
   93: 
   94: 
   95: \ Displaying:
   96: 
   97: : draw-bottom	\ --- ; redraw the bottom of the pit
   98: 		deep -1 position
   99: 		[char] + dup stone
  100: 		wide 0 do  [char] = dup stone  loop
  101: 		[char] + dup stone ;
  102: 
  103: : draw-frame	\ --- ; draw the border of the pit
  104: 		deep 0 do
  105: 		    i -1   position [char] | dup stone
  106: 		    i wide position [char] | dup stone
  107: 		loop  draw-bottom ;
  108: 
  109: : bottom-msg	\ addr cnt --- ; output a message in the bottom of the pit
  110: 		deep over 2/ wide swap - 2/ position type ;
  111: 
  112: : draw-line	\ line ---
  113: 		dup 0 position  wide 0 do  dup i pit 2c@ 2emit  loop  drop ;
  114: 
  115: : draw-pit	\ --- ; draw the contents of the pit
  116: 		deep 0 do  i draw-line  loop ;
  117: 
  118: : show-key	\ char --- ; visualization of that character
  119: 		dup bl <
  120: 		if  [char] @ or  [char] ^ emit  emit  space
  121: 		else  [char] ` emit  emit  [char] ' emit
  122: 		then ;
  123: 
  124: : show-help	\ --- ; display some explanations
  125: 		30  1 at-xy ." ***** T E T R I S *****"
  126: 		30  2 at-xy ." ======================="
  127: 		30  4 at-xy ." Use keys:"
  128: 		32  5 at-xy left-key	show-key ."  Move left"
  129: 		32  6 at-xy rot-key	show-key ."  Rotate"
  130: 		32  7 at-xy right-key	show-key ."  Move right"
  131: 		32  8 at-xy drop-key	show-key ."  Drop"
  132: 		32  9 at-xy pause-key	show-key ."  Pause"
  133: 		32 10 at-xy refresh-key	show-key ."  Refresh"
  134: 		32 11 at-xy quit-key	show-key ."  Quit"
  135: 		32 13 at-xy ." -> "
  136: 		30 16 at-xy ." Score:"
  137: 		30 17 at-xy ." Pieces:"
  138: 		30 18 at-xy ." Levels:"
  139: 		 0 22 at-xy ."  ==== This program was written 1994 in pure dpANS Forth by Dirk Uwe Zoller ===="
  140: 		 0 23 at-xy ."  =================== Copy it, port it, play it, enjoy it! =====================" ;
  141: 
  142: : update-score	\ --- ; display current score
  143: 		38 16 at-xy score @ 3 .r
  144: 		38 17 at-xy pieces @ 3 .r
  145: 		38 18 at-xy levels @ 3 .r ;
  146: 
  147: : refresh	\ --- ; redraw everything on screen
  148: 		page draw-frame draw-pit show-help update-score ;
  149: 
  150: 
  151: \ Define shapes of bricks:
  152: 
  153: : def-brick	create	4 0 do
  154: 			    ' execute  0 do  dup i chars + c@ c,  loop drop
  155: 			    refill drop
  156: 			loop
  157: 		does>	rot 4 * rot + 2* + ;
  158: 
  159: def-brick brick1	s"         "
  160: 			s" ######  "
  161: 			s"   ##    "
  162: 			s"         "
  163: 
  164: def-brick brick2	s"         "
  165: 			s" <><><><>"
  166: 			s"         "
  167: 			s"         "
  168: 
  169: def-brick brick3	s"         "
  170: 			s"   {}{}{}"
  171: 			s"   {}    "
  172: 			s"         "
  173: 
  174: def-brick brick4	s"         "
  175: 			s" ()()()  "
  176: 			s"     ()  "
  177: 			s"         "
  178: 
  179: def-brick brick5	s"         "
  180: 			s"   [][]  "
  181: 			s"   [][]  "
  182: 			s"         "
  183: 
  184: def-brick brick6	s"         "
  185: 			s" @@@@    "
  186: 			s"   @@@@  "
  187: 			s"         "
  188: 
  189: def-brick brick7	s"         "
  190: 			s"   %%%%  "
  191: 			s" %%%%    "
  192: 			s"         "
  193: 
  194: \ this brick is actually in use:
  195: 
  196: def-brick brick		s"         "
  197: 			s"         "
  198: 			s"         "
  199: 			s"         "
  200: 
  201: def-brick scratch	s"         "
  202: 			s"         "
  203: 			s"         "
  204: 			s"         "
  205: 
  206: create bricks	' brick1 ,  ' brick2 ,  ' brick3 ,  ' brick4 ,
  207: 		' brick5 ,  ' brick6 ,  ' brick7 ,
  208: 
  209: create brick-val 1 c, 2 c, 3 c, 3 c, 4 c, 5 c, 5 c,
  210: 
  211: 
  212: : is-brick	\ brick --- ; activate a shape of brick
  213: 		>body ['] brick >body 32 cmove ;
  214: 
  215: : new-brick	\ --- ; select a new brick by random, count it
  216: 		1 pieces +!  7 random
  217: 		bricks over cells + @ is-brick
  218: 		brick-val swap chars + c@ score +! ;
  219: 
  220: : rotleft	4 0 do 4 0 do
  221: 		    j i brick 2c@  3 i - j scratch 2c!
  222: 		loop loop
  223: 		['] scratch is-brick ;
  224: 
  225: : rotright	4 0 do 4 0 do
  226: 		    j i brick 2c@  i 3 j - scratch 2c!
  227: 		loop loop
  228: 		['] scratch is-brick ;
  229: 
  230: : draw-brick	\ row col ---
  231: 		4 0 do 4 0 do
  232: 		    j i brick 2c@  empty d<>
  233: 		    if  over j + over i +  position
  234: 			j i brick 2c@  stone
  235: 		    then
  236: 		loop loop  2drop ;
  237: 
  238: : show-brick	wiping off draw-brick ;
  239: : hide-brick	wiping on  draw-brick ;
  240: 
  241: : put-brick	\ row col --- ; put the brick into the pit
  242: 		4 0 do 4 0 do
  243: 		    j i brick 2c@  empty d<>
  244: 		    if  over j +  over i +  pit
  245: 			j i brick 2c@  rot 2c!
  246: 		    then
  247: 		loop loop  2drop ;
  248: 
  249: : remove-brick	\ row col --- ; remove the brick from that position
  250: 		4 0 do 4 0 do
  251: 		    j i brick 2c@  empty d<>
  252: 		    if  over j + over i + pit empty rot 2c!  then
  253: 		loop loop  2drop ;
  254: 
  255: : test-brick	\ row col --- flag ; could the brick be there?
  256: 		4 0 do 4 0 do
  257: 		    j i brick 2c@ empty d<>
  258: 		    if  over j +  over i +
  259: 			over dup 0< swap deep >= or
  260: 			over dup 0< swap wide >= or
  261: 			2swap pit 2c@  empty d<>
  262: 			or or if  unloop unloop 2drop false  exit  then
  263: 		    then
  264: 		loop loop  2drop true ;
  265: 
  266: : move-brick	\ rows cols --- flag ; try to move the brick
  267: 		brow @ bcol @ remove-brick
  268: 		swap brow @ + swap bcol @ + 2dup test-brick
  269: 		if  brow @ bcol @ hide-brick
  270: 		    2dup bcol ! brow !  2dup show-brick put-brick  true
  271: 		else  2drop brow @ bcol @ put-brick  false
  272: 		then ;
  273: 
  274: : rotate-brick	\ flag --- flag ; left/right, success
  275: 		brow @ bcol @ remove-brick
  276: 		dup if  rotright  else  rotleft  then
  277: 		brow @ bcol @ test-brick
  278: 		over if  rotleft  else  rotright  then
  279: 		if  brow @ bcol @ hide-brick
  280: 		    if  rotright  else  rotleft  then
  281: 		    brow @ bcol @ put-brick
  282: 		    brow @ bcol @ show-brick  true
  283: 		else  drop false  then ;
  284: 
  285: : insert-brick	\ row col --- flag ; introduce a new brick
  286: 		2dup test-brick
  287: 		if  2dup bcol ! brow !
  288: 		    2dup put-brick  draw-brick  true
  289: 		else  false  then ;
  290: 
  291: : drop-brick	\ --- ; move brick down fast
  292: 		begin  1 0 move-brick 0=  until ;
  293: 
  294: : move-line	\ from to ---
  295: 		over 0 pit  over 0 pit  wide 2*  cmove  draw-line
  296: 		dup 0 pit  wide 2*  blank  draw-line ;
  297: 
  298: : line-full	\ line-no --- flag
  299: 		true  wide 0
  300: 		do  over i pit 2c@ empty d=
  301: 		    if  drop false  leave  then
  302: 		loop nip ;
  303: 
  304: : remove-lines	\ ---
  305: 		deep deep
  306: 		begin
  307: 		    swap
  308: 		    begin  1- dup 0< if  2drop exit  then  dup line-full
  309: 		    while  1 levels +!  10 score +!  repeat
  310: 		    swap 1-
  311: 		    2dup <> if  2dup move-line  then
  312: 		again ;
  313: 
  314: : to-upper	\ char --- char ; convert to upper case
  315: 		dup [char] a >= over [char] z <= and if  bl -  then ;
  316: 
  317: : interaction	\ --- flag
  318: 		case  key to-upper
  319: 		    left-key	of  0 -1 move-brick drop  endof
  320: 		    right-key	of  0  1 move-brick drop  endof
  321: 		    rot-key	of  0 rotate-brick drop  endof
  322: 		    drop-key	of  drop-brick  endof
  323: 		    pause-key	of  S"  paused " bottom-msg  key drop
  324: 				    draw-bottom  endof
  325: 		    refresh-key	of  refresh  endof
  326: 		    quit-key	of  false exit  endof
  327: 		endcase  true ;
  328: 
  329: : initialize	\ --- ; prepare for playing
  330: 		randomize empty-pit refresh
  331: 		0 score !  0 pieces !  0 levels !  100 delay ! ;
  332: 
  333: : adjust-delay	\ --- ; make it faster with increasing score
  334: 		levels @
  335: 		dup  50 < if  100 over -  else
  336: 		dup 100 < if   62 over 4 / -  else
  337: 		dup 500 < if   31 over 16 / -  else  0  then then then
  338: 		delay !  drop ;
  339: 
  340: : play-game	\ --- ; play one tetris game
  341: 		begin
  342: 		    new-brick
  343: 		    -1 3 insert-brick
  344: 		while
  345: 		    begin  4 0
  346: 			do  35 13 at-xy
  347: 			    delay @ ms key?
  348: 			    if interaction 0=
  349: 				if  unloop exit  then
  350: 			    then
  351: 			loop
  352: 			1 0 move-brick  0=
  353: 		    until
  354: 		    remove-lines
  355: 		    update-score
  356: 		    adjust-delay
  357: 		repeat ;
  358: 
  359: forth definitions
  360: 
  361: : tt		\ --- ; play the tetris game
  362: 		initialize
  363: 		s"  Press any key " bottom-msg key drop draw-bottom
  364: 		begin
  365: 		    play-game
  366: 		    s"  Again? " bottom-msg key to-upper [char] Y =
  367: 		while  initialize  repeat
  368: 		0 23 at-xy cr ;
  369: 
  370: only forth also definitions

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>