File:  [gforth] / gforth / arch / misc / tt.fs
Revision 1.3: download - view: text, annotated - select for diffs
Sun Jul 5 20:50:02 1998 UTC (23 years, 6 months ago) by pazsan
Branches: MAIN
CVS tags: v0-5-0, v0-4-0, HEAD
Several fixes and typos I forgot to check in until recently
Documentation additions (not completed)

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

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