annotate examples_forth/tetris.4 @ 178:4d83154d2a78

add - {} some builtin in TL/1
author Shinji KONO <kono@ie.u-ryukyu.ac.jp>
date Mon, 15 Apr 2019 09:43:28 +0900
parents 2088fd998865
children
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
57
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
1 \
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
2 \ tetris.4th Tetris for terminals, redone in ANSI-Forth.
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
3 \ Written 05Apr94 by Dirk Uwe Zoller, e-mail:
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
4 \ duz@roxi.rz.fht-mannheim.de.
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
5 \ Look&feel stolen from Mike Taylor's "TETRIS FOR TERMINALS"
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
6 \
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
7 \ Please copy and share this program, modify it for your system
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
8 \ and improve it as you like. But don't remove this notice.
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
9 \
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
10 \ Thank you.
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
11 \
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
12 \ Changes:
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
13 \
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
14 \
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
15
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
16 ONLY FORTH DEFINITIONS
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
17 \ S" FORGET-TT" DROP 1 CHARS - FIND NIP [IF] FORGET-TT [THEN]
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
18 \ MARKER FORGET-TT
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
19
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
20 DECIMAL
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
21
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
22 WORDLIST CONSTANT TETRIS
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
23 GET-ORDER TETRIS DUP ROT 2 + SET-ORDER DEFINITIONS
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
24
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
25
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
26 \ Variables, constants
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
27
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
28 BL BL 2CONSTANT EMPTY \ an empty position
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
29 VARIABLE WIPING \ if true: wipe brick, else draw brick
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
30 2 CONSTANT COL0 \ position of the pit on screen
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
31 0 CONSTANT ROW0
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
32
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
33 10 CONSTANT WIDE \ size of pit in brick positions
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
34 20 CONSTANT DEEP
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
35
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
36 CHAR J VALUE LEFT-KEY \ customize if you don't like them
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
37 CHAR K VALUE ROT-KEY
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
38 CHAR L VALUE RIGHT-KEY
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
39 BL VALUE DROP-KEY
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
40 CHAR P VALUE PAUSE-KEY
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
41 12 VALUE REFRESH-KEY
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
42 CHAR Q VALUE QUIT-KEY
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
43
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
44 VARIABLE SCORE
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
45 VARIABLE PIECES
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
46 VARIABLE LEVELS
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
47 VARIABLE DELAY
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
48
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
49 VARIABLE BROW \ where the brick is
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
50 VARIABLE BCOL
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
51
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
52
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
53 \ stupid random number generator
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
54
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
55 VARIABLE SEED
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
56
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
57 : RANDOMIZE 0 ." Press any key." CR BEGIN 1+ KEY? UNTIL KEY DROP SEED ! ;
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
58
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
59 : RANDOM \ max --- n ; return random number < max
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
60 SEED @ 1103515245 * 12345 + [ HEX ] 07FFF [ DECIMAL ] AND
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
61 DUP SEED ! SWAP MOD ;
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
62
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
63
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
64 \ Access pairs of characters in memory:
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
65
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
66 : 2C@ DUP 1+ C@ SWAP C@ ;
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
67 : 2C! DUP >R C! R> 1+ C! ;
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
68
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
69
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
70 : <= > INVERT ;
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
71 : >= < INVERT ;
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
72 : D<> D= INVERT ;
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
73
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
74
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
75 \ Drawing primitives:
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
76
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
77 : 2EMIT EMIT EMIT ;
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
78
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
79 : POSITION \ row col --- ; cursor to the position in the pit
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
80 2* COL0 + SWAP ROW0 + AT-XY ;
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
81
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
82 : STONE \ c1 c2 --- ; draw or undraw these two characters
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
83 WIPING @ IF 2DROP 2 SPACES ELSE 2EMIT THEN ;
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
84
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
85
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
86 \ Define the pit where bricks fall into:
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
87
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
88 : DEF-PIT CREATE WIDE DEEP * 2* ALLOT
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
89 DOES> ROT WIDE * ROT + 2* CHARS + ;
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
90
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
91 DEF-PIT PIT
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
92
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
93 : EMPTY-PIT DEEP 0 DO WIDE 0 DO EMPTY J I PIT 2C!
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
94 LOOP LOOP ;
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
95
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
96
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
97 \ Displaying:
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
98
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
99 : DRAW-BOTTOM \ --- ; redraw the bottom of the pit
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
100 DEEP -1 POSITION
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
101 [CHAR] + DUP STONE
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
102 WIDE 0 DO [CHAR] = DUP STONE LOOP
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
103 [CHAR] + DUP STONE ;
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
104
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
105 : DRAW-FRAME \ --- ; draw the border of the pit
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
106 DEEP 0 DO
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
107 I -1 POSITION [CHAR] | DUP STONE
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
108 I WIDE POSITION [CHAR] | DUP STONE
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
109 LOOP DRAW-BOTTOM ;
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
110
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
111 : BOTTOM-MSG \ addr cnt --- ; output a message in the bottom of the pit
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
112 DEEP OVER 2/ WIDE SWAP - 2/ POSITION TYPE ;
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
113
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
114 : DRAW-LINE \ line ---
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
115 DUP 0 POSITION WIDE 0 DO DUP I PIT 2C@ 2EMIT LOOP DROP ;
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
116
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
117 : DRAW-PIT \ --- ; draw the contents of the pit
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
118 DEEP 0 DO I DRAW-LINE LOOP ;
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
119
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
120 : SHOW-KEY \ char --- ; visualization of that character
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
121 DUP BL <
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
122 IF [CHAR] @ OR [CHAR] ^ EMIT EMIT SPACE
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
123 ELSE [CHAR] ` EMIT EMIT [CHAR] ' EMIT
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
124 THEN ;
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
125
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
126 : SHOW-HELP \ --- ; display some explanations
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
127 30 1 AT-XY ." ***** T E T R I S *****"
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
128 30 2 AT-XY ." ======================="
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
129 30 4 AT-XY ." Use keys:"
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
130 32 5 AT-XY LEFT-KEY SHOW-KEY ." Move left"
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
131 32 6 AT-XY ROT-KEY SHOW-KEY ." Rotate"
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
132 32 7 AT-XY RIGHT-KEY SHOW-KEY ." Move right"
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
133 32 8 AT-XY DROP-KEY SHOW-KEY ." Drop"
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
134 32 9 AT-XY PAUSE-KEY SHOW-KEY ." Pause"
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
135 32 10 AT-XY REFRESH-KEY SHOW-KEY ." Refresh"
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
136 32 11 AT-XY QUIT-KEY SHOW-KEY ." Quit"
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
137 32 13 AT-XY ." -> "
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
138 30 16 AT-XY ." Score:"
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
139 30 17 AT-XY ." Pieces:"
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
140 30 18 AT-XY ." Levels:"
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
141 0 22 AT-XY ." ======= This program was written 1994 in ANS Forth by Dirk Uwe Zoller ========"
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
142 0 23 AT-XY ." =================== Copy it, port it, play it, enjoy it! =====================" ;
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
143
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
144 : UPDATE-SCORE \ --- ; display current score
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
145 38 16 AT-XY SCORE @ 3 .R
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
146 38 17 AT-XY PIECES @ 3 .R
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
147 38 18 AT-XY LEVELS @ 3 .R ;
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
148
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
149 : REFRESH \ --- ; redraw everything on screen
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
150 PAGE DRAW-FRAME DRAW-PIT SHOW-HELP UPDATE-SCORE ;
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
151
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
152
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
153 \ Define shapes of bricks:
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
154
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
155 : DEF-BRICK CREATE 4 0 DO
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
156 ' EXECUTE 0 DO DUP I CHARS + C@ C, LOOP DROP
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
157 REFILL DROP
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
158 LOOP
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
159 DOES> ROT 4 * ROT + 2* CHARS + ;
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
160
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
161 DEF-BRICK BRICK1 S" "
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
162 S" ###### "
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
163 S" ## "
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
164 S" "
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
165
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
166 DEF-BRICK BRICK2 S" "
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
167 S" <><><><>"
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
168 S" "
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
169 S" "
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
170
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
171 DEF-BRICK BRICK3 S" "
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
172 S" {}{}{}"
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
173 S" {} "
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
174 S" "
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
175
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
176 DEF-BRICK BRICK4 S" "
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
177 S" ()()() "
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
178 S" () "
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
179 S" "
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
180
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
181 DEF-BRICK BRICK5 S" "
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
182 S" [][] "
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
183 S" [][] "
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
184 S" "
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
185
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
186 DEF-BRICK BRICK6 S" "
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
187 S" @@@@ "
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
188 S" @@@@ "
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
189 S" "
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
190
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
191 DEF-BRICK BRICK7 S" "
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
192 S" %%%% "
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
193 S" %%%% "
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
194 S" "
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
195
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
196 \ this brick is actually in use:
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
197
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
198 DEF-BRICK BRICK S" "
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
199 S" "
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
200 S" "
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
201 S" "
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
202
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
203 DEF-BRICK SCRATCH S" "
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
204 S" "
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
205 S" "
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
206 S" "
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
207
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
208 CREATE BRICKS ' BRICK1 , ' BRICK2 , ' BRICK3 , ' BRICK4 ,
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
209 ' BRICK5 , ' BRICK6 , ' BRICK7 ,
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
210
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
211 CREATE BRICK-VAL 1 C, 2 C, 3 C, 3 C, 4 C, 5 C, 5 C,
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
212
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
213
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
214 : IS-BRICK \ brick --- ; activate a shape of brick
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
215 >BODY ['] BRICK >BODY 32 CMOVE ;
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
216
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
217 : NEW-BRICK \ --- ; select a new brick by random, count it
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
218 1 PIECES +! 7 RANDOM
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
219 BRICKS OVER CELLS + @ IS-BRICK
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
220 BRICK-VAL SWAP CHARS + C@ SCORE +! ;
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
221
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
222 : ROTLEFT 4 0 DO 4 0 DO
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
223 J I BRICK 2C@ 3 I - J SCRATCH 2C!
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
224 LOOP LOOP
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
225 ['] SCRATCH IS-BRICK ;
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
226
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
227 : ROTRIGHT 4 0 DO 4 0 DO
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
228 J I BRICK 2C@ I 3 J - SCRATCH 2C!
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
229 LOOP LOOP
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
230 ['] SCRATCH IS-BRICK ;
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
231
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
232 : DRAW-BRICK \ row col ---
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
233 4 0 DO 4 0 DO
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
234 J I BRICK 2C@ EMPTY D<>
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
235 IF OVER J + OVER I + POSITION
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
236 J I BRICK 2C@ STONE
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
237 THEN
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
238 LOOP LOOP 2DROP ;
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
239
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
240 : SHOW-BRICK FALSE WIPING ! DRAW-BRICK ;
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
241 : HIDE-BRICK TRUE WIPING ! DRAW-BRICK ;
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
242
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
243 : PUT-BRICK \ row col --- ; put the brick into the pit
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
244 4 0 DO 4 0 DO
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
245 J I BRICK 2C@ EMPTY D<>
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
246 IF OVER J + OVER I + PIT
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
247 J I BRICK 2C@ ROT 2C!
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
248 THEN
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
249 LOOP LOOP 2DROP ;
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
250
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
251 : REMOVE-BRICK \ row col --- ; remove the brick from that position
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
252 4 0 DO 4 0 DO
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
253 J I BRICK 2C@ EMPTY D<>
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
254 IF OVER J + OVER I + PIT EMPTY ROT 2C! THEN
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
255 LOOP LOOP 2DROP ;
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
256
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
257 : TEST-BRICK \ row col --- flag ; could the brick be there?
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
258 4 0 DO 4 0 DO
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
259 J I BRICK 2C@ EMPTY D<>
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
260 IF OVER J + OVER I +
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
261 OVER DUP 0< SWAP DEEP >= OR
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
262 OVER DUP 0< SWAP WIDE >= OR
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
263 2SWAP PIT 2C@ EMPTY D<>
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
264 OR OR IF UNLOOP UNLOOP 2DROP FALSE EXIT THEN
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
265 THEN
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
266 LOOP LOOP 2DROP TRUE ;
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
267
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
268 : MOVE-BRICK \ rows cols --- flag ; try to move the brick
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
269 BROW @ BCOL @ REMOVE-BRICK
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
270 SWAP BROW @ + SWAP BCOL @ + 2DUP TEST-BRICK
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
271 IF BROW @ BCOL @ HIDE-BRICK
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
272 2DUP BCOL ! BROW ! 2DUP SHOW-BRICK PUT-BRICK TRUE
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
273 ELSE 2DROP BROW @ BCOL @ PUT-BRICK FALSE
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
274 THEN ;
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
275
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
276 : ROTATE-BRICK \ flag --- flag ; left/right, success
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
277 BROW @ BCOL @ REMOVE-BRICK
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
278 DUP IF ROTRIGHT ELSE ROTLEFT THEN
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
279 BROW @ BCOL @ TEST-BRICK
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
280 OVER IF ROTLEFT ELSE ROTRIGHT THEN
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
281 IF BROW @ BCOL @ HIDE-BRICK
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
282 IF ROTRIGHT ELSE ROTLEFT THEN
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
283 BROW @ BCOL @ PUT-BRICK
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
284 BROW @ BCOL @ SHOW-BRICK TRUE
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
285 ELSE DROP FALSE THEN ;
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
286
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
287 : INSERT-BRICK \ row col --- flag ; introduce a new brick
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
288 2DUP TEST-BRICK
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
289 IF 2DUP BCOL ! BROW !
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
290 2DUP PUT-BRICK DRAW-BRICK TRUE
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
291 ELSE 2DROP FALSE THEN ;
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
292
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
293 : DROP-BRICK \ --- ; move brick down fast
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
294 BEGIN 1 0 MOVE-BRICK 0= UNTIL ;
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
295
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
296 : MOVE-LINE \ from to ---
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
297 OVER 0 PIT OVER 0 PIT WIDE 2* CMOVE DRAW-LINE
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
298 DUP 0 PIT WIDE 2* BLANK DRAW-LINE ;
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
299
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
300 : LINE-FULL \ line-no --- flag
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
301 TRUE WIDE 0
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
302 DO OVER I PIT 2C@ EMPTY D=
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
303 IF DROP FALSE LEAVE THEN
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
304 LOOP NIP ;
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
305
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
306 : REMOVE-LINES \ ---
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
307 DEEP DEEP
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
308 BEGIN
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
309 SWAP
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
310 BEGIN 1- DUP 0< IF 2DROP EXIT THEN DUP LINE-FULL
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
311 WHILE 1 LEVELS +! 10 SCORE +! REPEAT
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
312 SWAP 1-
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
313 2DUP <> IF 2DUP MOVE-LINE THEN
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
314 AGAIN ;
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
315
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
316 : TO-UPPER \ char --- char ; convert to upper case
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
317 DUP [CHAR] a >= OVER [CHAR] z <= AND
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
318 IF [ CHAR A CHAR a - ] LITERAL + THEN ;
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
319
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
320 : DISPATCH \ key --- flag
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
321 CASE TO-UPPER
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
322 LEFT-KEY OF 0 -1 MOVE-BRICK DROP ENDOF
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
323 RIGHT-KEY OF 0 1 MOVE-BRICK DROP ENDOF
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
324 ROT-KEY OF 0 ROTATE-BRICK DROP ENDOF
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
325 DROP-KEY OF DROP-BRICK ENDOF
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
326 PAUSE-KEY OF S" Paused " BOTTOM-MSG KEY DROP
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
327 DRAW-BOTTOM ENDOF
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
328 REFRESH-KEY OF REFRESH ENDOF
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
329 QUIT-KEY OF FALSE EXIT ENDOF
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
330 ENDCASE TRUE ;
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
331
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
332 : INITIALIZE \ --- ; prepare for playing
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
333 RANDOMIZE EMPTY-PIT REFRESH
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
334 0 SCORE ! 0 PIECES ! 0 LEVELS ! 100 DELAY ! ;
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
335
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
336 : ADJUST-DELAY \ --- ; make it faster with increasing score
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
337 LEVELS @
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
338 DUP 50 < IF 100 OVER - ELSE
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
339 DUP 100 < IF 62 OVER 4 / - ELSE
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
340 DUP 500 < IF 31 OVER 16 / - ELSE 0 THEN THEN THEN
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
341 DELAY ! DROP ;
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
342
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
343 : PLAY-GAME \ --- ; play one tetris game
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
344 BEGIN
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
345 NEW-BRICK
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
346 -1 3 INSERT-BRICK
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
347 WHILE
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
348 BEGIN 4 0
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
349 DO 35 13 AT-XY
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
350 DELAY @ MS KEY?
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
351 IF BEGIN KEY KEY? WHILE DROP REPEAT
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
352 DISPATCH 0=
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
353 IF UNLOOP EXIT THEN
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
354 THEN
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
355 LOOP
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
356 1 0 MOVE-BRICK 0=
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
357 UNTIL
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
358 REMOVE-LINES
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
359 UPDATE-SCORE
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
360 ADJUST-DELAY
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
361 REPEAT ;
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
362
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
363 FORTH DEFINITIONS
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
364
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
365 : TT \ --- ; play the tetris game
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
366 INITIALIZE
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
367 S" Press any key " BOTTOM-MSG KEY DROP DRAW-BOTTOM
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
368 BEGIN
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
369 PLAY-GAME
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
370 S" Again? " BOTTOM-MSG KEY TO-UPPER [CHAR] Y =
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
371 WHILE INITIALIZE REPEAT
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
372 0 23 AT-XY CR ;
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
373
2088fd998865 sbc09 directry clean up
Shinji KONO <kono@ie.u-ryukyu.ac.jp>
parents:
diff changeset
374 ONLY FORTH ALSO DEFINITIONS