Mercurial > hg > Members > kono > os9 > sbc09

comparison examples_forth/tetris.4 @ 57:2088fd998865

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
sbc09 directry clean up
author Shinji KONO <kono@ie.u-ryukyu.ac.jp>
date Mon, 23 Jul 2018 16:07:12 +0900
parents
children
comparison
equal deleted inserted replaced
56:4fa2bdb0c457 57:2088fd998865
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