-
Notifications
You must be signed in to change notification settings - Fork 2
/
boot.fs
245 lines (208 loc) · 5.73 KB
/
boot.fs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
s" Retro-40 ROM Booting" TYPE CR
\ ------------------------------------------------------------
\ COMPATIBILITY AND CONVENIENCE
\ ------------------------------------------------------------
: <= ( a b -- f ) 2DUP < -ROT = OR ;
: >= ( a b -- f ) 2DUP > -ROT = OR ;
: F>= ( F: a b -- ) F2DUP F= F> OR ;
: F<= ( F: a b -- ) F2DUP F= F< OR ;
: NOT ( u -- f ) 0= IF -1 ELSE 0 THEN ;
: 3DUP ( a b c -- a b c a b c ) 3 PICK 3 PICK 3 PICK ;
\ Chuck Moore
: UNDER+ ( a b c -- a+c b ) ROT + SWAP ;
\ more stack-related operators
: PLUCK ( an+1 an an-1 .. a1 n -- an1+ an-1 .. a1 ) ROLL DROP ;
: PIVOT ( a b c -- c b a ) SWAP ROT ;
: RND ( u -- u' ) RANDOM SWAP MOD ;
: CELLS+ ( addr u -- addr' ) CELLS + ;
: CELLS- ( addr u -- addr' ) CELLS - ;
\ ------------------------------------------------------------
\ LINES
\ ------------------------------------------------------------
VARIABLE ww
VARIABLE hh
VARIABLE dx1
VARIABLE dy1
VARIABLE dx2
VARIABLE dy2
VARIABLE longest
VARIABLE shortest
VARIABLE numerator
: init
0 ww !
0 hh !
0 dx1 !
0 dy1 !
0 dx2 !
0 dy2 !
0 longest !
0 shortest !
0 numerator !
;
: sethw ( x y x2 y2 -- ) ROT - hh ! SWAP - ww ! ;
: setdx1 ( -- ) ww @ 0< IF -1 dx1 ! ELSE ww @ 0> IF 1 dx1 ! THEN THEN ;
: setdx2 ( -- ) ww @ 0< IF -1 dx2 ! ELSE ww @ 0> IF 1 dx2 ! THEN THEN ;
: setdy1 ( -- ) hh @ 0< IF -1 dy1 ! ELSE hh @ 0> IF 1 dy1 ! THEN THEN ;
: setdy2 ( -- ) hh @ 0< IF -1 dy2 ! ELSE hh @ 0> IF 1 dy2 ! THEN THEN ;
: setnumerator ( -- ) longest @ 1 RSHIFT numerator ! ;
: setsl ( -- )
ww @ ABS longest !
hh @ ABS shortest !
longest @ shortest @ <= IF
hh @ ABS longest !
ww @ ABS shortest !
setdy2
0 dx2 !
THEN ;
: line ( color x y x2 y2 -- )
{ color x y x2 y2 }
init
x y x2 y2 sethw
setdx1
setdx2
setdy1
setsl
setnumerator
longest @ 1+ 0 ?DO
color x y p!
shortest @ numerator +!
numerator @ longest @ >= IF
longest @ NEGATE numerator +!
dx1 @ x + TO x
dy1 @ y + TO y
ELSE
dx2 @ x + TO x
dy2 @ y + TO y
THEN
LOOP ;
\ ------------------------------------------------------------
\ RECTANGLES
\ ------------------------------------------------------------
: rect { color x y w h | xw -- }
x w + TO xw
h 0 ?DO color x y i + xw 1- OVER line LOOP
;
: rectb ( color x y w h -- )
{ color x y w h | yh xw -- }
x w + 1- TO xw
y h + 1- TO yh
xw x ?DO color I y p! LOOP
xw x ?DO color I yh p! LOOP
yh 1+ y ?DO color x I p! color xw I p! LOOP
;
\ ------------------------------------------------------------
\ CIRCLES
\ ------------------------------------------------------------
: circ ( color x0 y0 radius -- )
{ color x0 y0 radius | x y -- }
radius 1+ radius NEGATE ?DO
radius 1+ radius NEGATE ?DO
I I * J J * + radius radius * radius + < IF
color x0 I + y0 J + p!
THEN
LOOP
LOOP ;
: circb ( color x0 y0 radius -- )
{ color x0 y0 radius -- }
radius 1+ radius NEGATE ?DO
radius 1+ radius NEGATE ?DO
I I * J J * + radius radius * radius - >
I I * J J * + radius radius * radius + <
AND IF
color x0 I + y0 J + p!
THEN
LOOP
LOOP ;
\ \ ------------------------------------------------------------
\ \ RECTS DEMO
\ \ ------------------------------------------------------------
\ 0 VALUE x
\ 0 VALUE y
\ 0 VALUE dx
\ 0 VALUE dy
\ 0 VALUE col
\ : <init>
\ W 2/ TO x
\ H 2/ TO y
\ 6 TO dx
\ 4 TO dy
\ 4 TO col
\ ;
\ : bounce-rect
\ dx x + TO x
\ dy y + TO y
\ x 0< x W 6 - > OR IF
\ dx NEGATE TO dx
\ col 1+ 15 mod 1 MAX TO col
\ THEN
\ y 0< y H 6 - > OR IF
\ dy NEGATE TO dy
\ col 1+ 16 mod 1 MAX TO col
\ THEN
\ col x y 6 6 rect
\ ;
\ : rp! ( -- ) RANDOM 15 MOD 1+ RANDOM W MOD RANDOM H MOD P! ;
\ : rl! ( -- ) RANDOM 15 MOD 1+ RANDOM W MOD RANDOM H MOD RANDOM W MOD RANDOM H MOD line ;
\ : rr! ( -- ) RANDOM 15 MOD 1+ RANDOM W MOD RANDOM H MOD RANDOM W MOD 2/ RANDOM H MOD 2/ rect ;
\ : rc! ( -- ) RANDOM 15 MOD 1+ RANDOM W MOD RANDOM H MOD RANDOM H MOD 2/ circ ;
\ \ : update ( -- ) 10 0 do rp! rl! rr! rc! bounce-rect loop ;
\ \ define a sprite
\ 1 3 3 1 sp!
\ 2 4 3 1 sp!
\ 3 3 4 1 sp!
\ 4 4 4 1 sp!
\ \ regular keyboard input, with repeat and all
\ : input ( -- )
\ SCANCODE_A pressed? IF x 1- TO x THEN
\ SCANCODE_D pressed? IF x 1+ TO x THEN
\ SCANCODE_W pressed? IF y 1- TO y THEN
\ SCANCODE_S pressed? IF y 1+ TO y THEN
\ ;
\ : update ( -- ) input x y 1 spr ;
\ run cycle machinery
\ define DEFER and IS (and WHAT'S perhaps?)
\ for the moment values will do...
: noop ;
' noop VALUE update-fn
' noop VALUE draw-fn
' noop VALUE init-fn
: init init-fn execute ;
: update update-fn execute draw-fn execute ;
: install ( "name" -- )
CREATE \ \ check for missing functions?
c" <update>" FIND NOT ABORT" <UPDATE> not found" ,
c" <draw>" FIND NOT ABORT" <DRAW> not found" ,
c" <init>" FIND NOT ABORT" <INIT> not found" ,
DOES>
DUP @ TO update-fn CELL+
DUP @ TO draw-fn CELL+
@ TO init-fn
init
;
\ default palette DB16
0x14 0x0C 0x1C 0 0 PAL!
0x44 0x24 0x34 1 0 PAL!
0x30 0x34 0x6D 2 0 PAL!
0x4E 0x4A 0x4F 3 0 PAL!
0x85 0x4C 0x30 4 0 PAL!
0x34 0x65 0x24 5 0 PAL!
0xD0 0x46 0x48 6 0 PAL!
0x75 0x71 0x61 7 0 PAL!
0x59 0x7D 0xCE 8 0 PAL!
0xD2 0x7D 0x2C 9 0 PAL!
0x85 0x95 0xA1 10 0 PAL!
0x6D 0xAA 0x2C 11 0 PAL!
0xD2 0xAA 0x99 12 0 PAL!
0x6D 0xC2 0xCA 13 0 PAL!
0xDA 0xD4 0x5E 14 0 PAL!
0xDE 0xEE 0xD6 15 0 PAL!
\ load some code
INCLUDE input.fs
INCLUDE font.fs
INCLUDE console.fs
INCLUDE sprite-editor.fs
INCLUDE map-editor.fs
INCLUDE snake.fs
\ run the console program
S" Retro-40 Initialised" ?puts CR CR
\ retro-40