Powered by ViewCVS 1.0-dev
| 1 : | pazsan | 1.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" drop 1- find nip [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 |
|
CVS Admin Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |