![[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|
Return to tt.fs CVS log | Up to [gforth] / gforth |
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: only forth also definitions
1.2 pazsan 14: s" forget-tt" sfind [if] forget-tt [then] marker forget-tt
1.1 pazsan 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?
1.3 ! anton 348: if interaction 0=
1.1 pazsan 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