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