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