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