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