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