57
|
1 \
|
|
2 \ tetris.4th Tetris for terminals, redone in ANSI-Forth.
|
|
3 \ Written 05Apr94 by Dirk Uwe Zoller, e-mail:
|
|
4 \ 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 \ Changes:
|
|
13 \
|
|
14 \
|
|
15
|
|
16 ONLY FORTH DEFINITIONS
|
|
17 \ S" FORGET-TT" DROP 1 CHARS - FIND NIP [IF] FORGET-TT [THEN]
|
|
18 \ MARKER FORGET-TT
|
|
19
|
|
20 DECIMAL
|
|
21
|
|
22 WORDLIST CONSTANT TETRIS
|
|
23 GET-ORDER TETRIS DUP ROT 2 + SET-ORDER DEFINITIONS
|
|
24
|
|
25
|
|
26 \ Variables, constants
|
|
27
|
|
28 BL BL 2CONSTANT EMPTY \ an empty position
|
|
29 VARIABLE WIPING \ if true: wipe brick, else draw brick
|
|
30 2 CONSTANT COL0 \ position of the pit on screen
|
|
31 0 CONSTANT ROW0
|
|
32
|
|
33 10 CONSTANT WIDE \ size of pit in brick positions
|
|
34 20 CONSTANT DEEP
|
|
35
|
|
36 CHAR J VALUE LEFT-KEY \ customize if you don't like them
|
|
37 CHAR K VALUE ROT-KEY
|
|
38 CHAR L VALUE RIGHT-KEY
|
|
39 BL VALUE DROP-KEY
|
|
40 CHAR P VALUE PAUSE-KEY
|
|
41 12 VALUE REFRESH-KEY
|
|
42 CHAR Q VALUE QUIT-KEY
|
|
43
|
|
44 VARIABLE SCORE
|
|
45 VARIABLE PIECES
|
|
46 VARIABLE LEVELS
|
|
47 VARIABLE DELAY
|
|
48
|
|
49 VARIABLE BROW \ where the brick is
|
|
50 VARIABLE BCOL
|
|
51
|
|
52
|
|
53 \ stupid random number generator
|
|
54
|
|
55 VARIABLE SEED
|
|
56
|
|
57 : RANDOMIZE 0 ." Press any key." CR BEGIN 1+ KEY? UNTIL KEY DROP SEED ! ;
|
|
58
|
|
59 : RANDOM \ max --- n ; return random number < max
|
|
60 SEED @ 1103515245 * 12345 + [ HEX ] 07FFF [ DECIMAL ] AND
|
|
61 DUP SEED ! SWAP MOD ;
|
|
62
|
|
63
|
|
64 \ Access pairs of characters in memory:
|
|
65
|
|
66 : 2C@ DUP 1+ C@ SWAP C@ ;
|
|
67 : 2C! DUP >R C! R> 1+ C! ;
|
|
68
|
|
69
|
|
70 : <= > INVERT ;
|
|
71 : >= < INVERT ;
|
|
72 : D<> D= INVERT ;
|
|
73
|
|
74
|
|
75 \ Drawing primitives:
|
|
76
|
|
77 : 2EMIT EMIT EMIT ;
|
|
78
|
|
79 : POSITION \ row col --- ; cursor to the position in the pit
|
|
80 2* COL0 + SWAP ROW0 + AT-XY ;
|
|
81
|
|
82 : STONE \ c1 c2 --- ; draw or undraw these two characters
|
|
83 WIPING @ IF 2DROP 2 SPACES ELSE 2EMIT THEN ;
|
|
84
|
|
85
|
|
86 \ Define the pit where bricks fall into:
|
|
87
|
|
88 : DEF-PIT CREATE WIDE DEEP * 2* ALLOT
|
|
89 DOES> ROT WIDE * ROT + 2* CHARS + ;
|
|
90
|
|
91 DEF-PIT PIT
|
|
92
|
|
93 : EMPTY-PIT DEEP 0 DO WIDE 0 DO EMPTY J I PIT 2C!
|
|
94 LOOP LOOP ;
|
|
95
|
|
96
|
|
97 \ Displaying:
|
|
98
|
|
99 : DRAW-BOTTOM \ --- ; redraw the bottom of the pit
|
|
100 DEEP -1 POSITION
|
|
101 [CHAR] + DUP STONE
|
|
102 WIDE 0 DO [CHAR] = DUP STONE LOOP
|
|
103 [CHAR] + DUP STONE ;
|
|
104
|
|
105 : DRAW-FRAME \ --- ; draw the border of the pit
|
|
106 DEEP 0 DO
|
|
107 I -1 POSITION [CHAR] | DUP STONE
|
|
108 I WIDE POSITION [CHAR] | DUP STONE
|
|
109 LOOP DRAW-BOTTOM ;
|
|
110
|
|
111 : BOTTOM-MSG \ addr cnt --- ; output a message in the bottom of the pit
|
|
112 DEEP OVER 2/ WIDE SWAP - 2/ POSITION TYPE ;
|
|
113
|
|
114 : DRAW-LINE \ line ---
|
|
115 DUP 0 POSITION WIDE 0 DO DUP I PIT 2C@ 2EMIT LOOP DROP ;
|
|
116
|
|
117 : DRAW-PIT \ --- ; draw the contents of the pit
|
|
118 DEEP 0 DO I DRAW-LINE LOOP ;
|
|
119
|
|
120 : SHOW-KEY \ char --- ; visualization of that character
|
|
121 DUP BL <
|
|
122 IF [CHAR] @ OR [CHAR] ^ EMIT EMIT SPACE
|
|
123 ELSE [CHAR] ` EMIT EMIT [CHAR] ' EMIT
|
|
124 THEN ;
|
|
125
|
|
126 : SHOW-HELP \ --- ; display some explanations
|
|
127 30 1 AT-XY ." ***** T E T R I S *****"
|
|
128 30 2 AT-XY ." ======================="
|
|
129 30 4 AT-XY ." Use keys:"
|
|
130 32 5 AT-XY LEFT-KEY SHOW-KEY ." Move left"
|
|
131 32 6 AT-XY ROT-KEY SHOW-KEY ." Rotate"
|
|
132 32 7 AT-XY RIGHT-KEY SHOW-KEY ." Move right"
|
|
133 32 8 AT-XY DROP-KEY SHOW-KEY ." Drop"
|
|
134 32 9 AT-XY PAUSE-KEY SHOW-KEY ." Pause"
|
|
135 32 10 AT-XY REFRESH-KEY SHOW-KEY ." Refresh"
|
|
136 32 11 AT-XY QUIT-KEY SHOW-KEY ." Quit"
|
|
137 32 13 AT-XY ." -> "
|
|
138 30 16 AT-XY ." Score:"
|
|
139 30 17 AT-XY ." Pieces:"
|
|
140 30 18 AT-XY ." Levels:"
|
|
141 0 22 AT-XY ." ======= This program was written 1994 in ANS Forth by Dirk Uwe Zoller ========"
|
|
142 0 23 AT-XY ." =================== Copy it, port it, play it, enjoy it! =====================" ;
|
|
143
|
|
144 : UPDATE-SCORE \ --- ; display current score
|
|
145 38 16 AT-XY SCORE @ 3 .R
|
|
146 38 17 AT-XY PIECES @ 3 .R
|
|
147 38 18 AT-XY LEVELS @ 3 .R ;
|
|
148
|
|
149 : REFRESH \ --- ; redraw everything on screen
|
|
150 PAGE DRAW-FRAME DRAW-PIT SHOW-HELP UPDATE-SCORE ;
|
|
151
|
|
152
|
|
153 \ Define shapes of bricks:
|
|
154
|
|
155 : DEF-BRICK CREATE 4 0 DO
|
|
156 ' EXECUTE 0 DO DUP I CHARS + C@ C, LOOP DROP
|
|
157 REFILL DROP
|
|
158 LOOP
|
|
159 DOES> ROT 4 * ROT + 2* CHARS + ;
|
|
160
|
|
161 DEF-BRICK BRICK1 S" "
|
|
162 S" ###### "
|
|
163 S" ## "
|
|
164 S" "
|
|
165
|
|
166 DEF-BRICK BRICK2 S" "
|
|
167 S" <><><><>"
|
|
168 S" "
|
|
169 S" "
|
|
170
|
|
171 DEF-BRICK BRICK3 S" "
|
|
172 S" {}{}{}"
|
|
173 S" {} "
|
|
174 S" "
|
|
175
|
|
176 DEF-BRICK BRICK4 S" "
|
|
177 S" ()()() "
|
|
178 S" () "
|
|
179 S" "
|
|
180
|
|
181 DEF-BRICK BRICK5 S" "
|
|
182 S" [][] "
|
|
183 S" [][] "
|
|
184 S" "
|
|
185
|
|
186 DEF-BRICK BRICK6 S" "
|
|
187 S" @@@@ "
|
|
188 S" @@@@ "
|
|
189 S" "
|
|
190
|
|
191 DEF-BRICK BRICK7 S" "
|
|
192 S" %%%% "
|
|
193 S" %%%% "
|
|
194 S" "
|
|
195
|
|
196 \ this brick is actually in use:
|
|
197
|
|
198 DEF-BRICK BRICK S" "
|
|
199 S" "
|
|
200 S" "
|
|
201 S" "
|
|
202
|
|
203 DEF-BRICK SCRATCH S" "
|
|
204 S" "
|
|
205 S" "
|
|
206 S" "
|
|
207
|
|
208 CREATE BRICKS ' BRICK1 , ' BRICK2 , ' BRICK3 , ' BRICK4 ,
|
|
209 ' BRICK5 , ' BRICK6 , ' BRICK7 ,
|
|
210
|
|
211 CREATE BRICK-VAL 1 C, 2 C, 3 C, 3 C, 4 C, 5 C, 5 C,
|
|
212
|
|
213
|
|
214 : IS-BRICK \ brick --- ; activate a shape of brick
|
|
215 >BODY ['] BRICK >BODY 32 CMOVE ;
|
|
216
|
|
217 : NEW-BRICK \ --- ; select a new brick by random, count it
|
|
218 1 PIECES +! 7 RANDOM
|
|
219 BRICKS OVER CELLS + @ IS-BRICK
|
|
220 BRICK-VAL SWAP CHARS + C@ SCORE +! ;
|
|
221
|
|
222 : ROTLEFT 4 0 DO 4 0 DO
|
|
223 J I BRICK 2C@ 3 I - J SCRATCH 2C!
|
|
224 LOOP LOOP
|
|
225 ['] SCRATCH IS-BRICK ;
|
|
226
|
|
227 : ROTRIGHT 4 0 DO 4 0 DO
|
|
228 J I BRICK 2C@ I 3 J - SCRATCH 2C!
|
|
229 LOOP LOOP
|
|
230 ['] SCRATCH IS-BRICK ;
|
|
231
|
|
232 : DRAW-BRICK \ row col ---
|
|
233 4 0 DO 4 0 DO
|
|
234 J I BRICK 2C@ EMPTY D<>
|
|
235 IF OVER J + OVER I + POSITION
|
|
236 J I BRICK 2C@ STONE
|
|
237 THEN
|
|
238 LOOP LOOP 2DROP ;
|
|
239
|
|
240 : SHOW-BRICK FALSE WIPING ! DRAW-BRICK ;
|
|
241 : HIDE-BRICK TRUE WIPING ! DRAW-BRICK ;
|
|
242
|
|
243 : PUT-BRICK \ row col --- ; put the brick into the pit
|
|
244 4 0 DO 4 0 DO
|
|
245 J I BRICK 2C@ EMPTY D<>
|
|
246 IF OVER J + OVER I + PIT
|
|
247 J I BRICK 2C@ ROT 2C!
|
|
248 THEN
|
|
249 LOOP LOOP 2DROP ;
|
|
250
|
|
251 : REMOVE-BRICK \ row col --- ; remove the brick from that position
|
|
252 4 0 DO 4 0 DO
|
|
253 J I BRICK 2C@ EMPTY D<>
|
|
254 IF OVER J + OVER I + PIT EMPTY ROT 2C! THEN
|
|
255 LOOP LOOP 2DROP ;
|
|
256
|
|
257 : TEST-BRICK \ row col --- flag ; could the brick be there?
|
|
258 4 0 DO 4 0 DO
|
|
259 J I BRICK 2C@ EMPTY D<>
|
|
260 IF OVER J + OVER I +
|
|
261 OVER DUP 0< SWAP DEEP >= OR
|
|
262 OVER DUP 0< SWAP WIDE >= OR
|
|
263 2SWAP PIT 2C@ EMPTY D<>
|
|
264 OR OR IF UNLOOP UNLOOP 2DROP FALSE EXIT THEN
|
|
265 THEN
|
|
266 LOOP LOOP 2DROP TRUE ;
|
|
267
|
|
268 : MOVE-BRICK \ rows cols --- flag ; try to move the brick
|
|
269 BROW @ BCOL @ REMOVE-BRICK
|
|
270 SWAP BROW @ + SWAP BCOL @ + 2DUP TEST-BRICK
|
|
271 IF BROW @ BCOL @ HIDE-BRICK
|
|
272 2DUP BCOL ! BROW ! 2DUP SHOW-BRICK PUT-BRICK TRUE
|
|
273 ELSE 2DROP BROW @ BCOL @ PUT-BRICK FALSE
|
|
274 THEN ;
|
|
275
|
|
276 : ROTATE-BRICK \ flag --- flag ; left/right, success
|
|
277 BROW @ BCOL @ REMOVE-BRICK
|
|
278 DUP IF ROTRIGHT ELSE ROTLEFT THEN
|
|
279 BROW @ BCOL @ TEST-BRICK
|
|
280 OVER IF ROTLEFT ELSE ROTRIGHT THEN
|
|
281 IF BROW @ BCOL @ HIDE-BRICK
|
|
282 IF ROTRIGHT ELSE ROTLEFT THEN
|
|
283 BROW @ BCOL @ PUT-BRICK
|
|
284 BROW @ BCOL @ SHOW-BRICK TRUE
|
|
285 ELSE DROP FALSE THEN ;
|
|
286
|
|
287 : INSERT-BRICK \ row col --- flag ; introduce a new brick
|
|
288 2DUP TEST-BRICK
|
|
289 IF 2DUP BCOL ! BROW !
|
|
290 2DUP PUT-BRICK DRAW-BRICK TRUE
|
|
291 ELSE 2DROP FALSE THEN ;
|
|
292
|
|
293 : DROP-BRICK \ --- ; move brick down fast
|
|
294 BEGIN 1 0 MOVE-BRICK 0= UNTIL ;
|
|
295
|
|
296 : MOVE-LINE \ from to ---
|
|
297 OVER 0 PIT OVER 0 PIT WIDE 2* CMOVE DRAW-LINE
|
|
298 DUP 0 PIT WIDE 2* BLANK DRAW-LINE ;
|
|
299
|
|
300 : LINE-FULL \ line-no --- flag
|
|
301 TRUE WIDE 0
|
|
302 DO OVER I PIT 2C@ EMPTY D=
|
|
303 IF DROP FALSE LEAVE THEN
|
|
304 LOOP NIP ;
|
|
305
|
|
306 : REMOVE-LINES \ ---
|
|
307 DEEP DEEP
|
|
308 BEGIN
|
|
309 SWAP
|
|
310 BEGIN 1- DUP 0< IF 2DROP EXIT THEN DUP LINE-FULL
|
|
311 WHILE 1 LEVELS +! 10 SCORE +! REPEAT
|
|
312 SWAP 1-
|
|
313 2DUP <> IF 2DUP MOVE-LINE THEN
|
|
314 AGAIN ;
|
|
315
|
|
316 : TO-UPPER \ char --- char ; convert to upper case
|
|
317 DUP [CHAR] a >= OVER [CHAR] z <= AND
|
|
318 IF [ CHAR A CHAR a - ] LITERAL + THEN ;
|
|
319
|
|
320 : DISPATCH \ key --- flag
|
|
321 CASE TO-UPPER
|
|
322 LEFT-KEY OF 0 -1 MOVE-BRICK DROP ENDOF
|
|
323 RIGHT-KEY OF 0 1 MOVE-BRICK DROP ENDOF
|
|
324 ROT-KEY OF 0 ROTATE-BRICK DROP ENDOF
|
|
325 DROP-KEY OF DROP-BRICK ENDOF
|
|
326 PAUSE-KEY OF S" Paused " BOTTOM-MSG KEY DROP
|
|
327 DRAW-BOTTOM ENDOF
|
|
328 REFRESH-KEY OF REFRESH ENDOF
|
|
329 QUIT-KEY OF FALSE EXIT ENDOF
|
|
330 ENDCASE TRUE ;
|
|
331
|
|
332 : INITIALIZE \ --- ; prepare for playing
|
|
333 RANDOMIZE EMPTY-PIT REFRESH
|
|
334 0 SCORE ! 0 PIECES ! 0 LEVELS ! 100 DELAY ! ;
|
|
335
|
|
336 : ADJUST-DELAY \ --- ; make it faster with increasing score
|
|
337 LEVELS @
|
|
338 DUP 50 < IF 100 OVER - ELSE
|
|
339 DUP 100 < IF 62 OVER 4 / - ELSE
|
|
340 DUP 500 < IF 31 OVER 16 / - ELSE 0 THEN THEN THEN
|
|
341 DELAY ! DROP ;
|
|
342
|
|
343 : PLAY-GAME \ --- ; play one tetris game
|
|
344 BEGIN
|
|
345 NEW-BRICK
|
|
346 -1 3 INSERT-BRICK
|
|
347 WHILE
|
|
348 BEGIN 4 0
|
|
349 DO 35 13 AT-XY
|
|
350 DELAY @ MS KEY?
|
|
351 IF BEGIN KEY KEY? WHILE DROP REPEAT
|
|
352 DISPATCH 0=
|
|
353 IF UNLOOP EXIT THEN
|
|
354 THEN
|
|
355 LOOP
|
|
356 1 0 MOVE-BRICK 0=
|
|
357 UNTIL
|
|
358 REMOVE-LINES
|
|
359 UPDATE-SCORE
|
|
360 ADJUST-DELAY
|
|
361 REPEAT ;
|
|
362
|
|
363 FORTH DEFINITIONS
|
|
364
|
|
365 : TT \ --- ; play the tetris game
|
|
366 INITIALIZE
|
|
367 S" Press any key " BOTTOM-MSG KEY DROP DRAW-BOTTOM
|
|
368 BEGIN
|
|
369 PLAY-GAME
|
|
370 S" Again? " BOTTOM-MSG KEY TO-UPPER [CHAR] Y =
|
|
371 WHILE INITIALIZE REPEAT
|
|
372 0 23 AT-XY CR ;
|
|
373
|
|
374 ONLY FORTH ALSO DEFINITIONS
|