PageRenderTime 82ms CodeModel.GetById 19ms app.highlight 59ms RepoModel.GetById 1ms app.codeStats 0ms

/extra/space-invaders/space-invaders.factor

http://github.com/abeaumont/factor
Unknown | 402 lines | 341 code | 61 blank | 0 comment | 0 complexity | 2beb1ded2979f5384e21bfe8e5296879 MD5 | raw file
  1! Copyright (C) 2006 Chris Double.
  2! See http://factorcode.org/license.txt for BSD license.
  3!
  4USING: 
  5    accessors
  6    alien.c-types
  7    alien.data
  8    arrays
  9    byte-arrays
 10    calendar
 11    combinators
 12    cpu.8080 
 13    cpu.8080.emulator
 14    io.files
 15    io.pathnames
 16    kernel 
 17    locals
 18    math
 19    math.order
 20    openal
 21    openal.alut
 22    opengl.gl
 23    sequences
 24    ui
 25    ui.gadgets
 26    ui.gestures
 27    ui.render
 28    specialized-arrays
 29;
 30QUALIFIED: threads
 31QUALIFIED: system
 32SPECIALIZED-ARRAY: uchar
 33IN: space-invaders
 34
 35TUPLE: space-invaders < cpu port1 port2i port2o port3o port4lo port4hi port5o bitmap sounds looping? ;
 36CONSTANT: game-width 224
 37CONSTANT: game-height 256
 38
 39: make-opengl-bitmap ( -- array )
 40  game-height game-width 3 * * uchar <c-array> ;
 41
 42: bitmap-index ( point -- index )
 43  #! Point is a {x y}.
 44  first2 game-width 3 * * swap 3 * + ;
 45
 46:: set-bitmap-pixel ( bitmap point color -- )
 47    point bitmap-index :> index
 48    color first  index     bitmap set-nth
 49    color second index 1 + bitmap set-nth
 50    color third  index 2 + bitmap set-nth ;
 51
 52: get-bitmap-pixel ( point array -- color )
 53  #! Point is a {x y}. color is a {r g b} 
 54  [ bitmap-index ] dip
 55  [ nth ] 2keep
 56  [ [ 1 + ] dip nth ] 2keep
 57  [ 2 + ] dip nth 3array ;
 58  
 59CONSTANT: SOUND-SHOT         0 
 60CONSTANT: SOUND-UFO          1 
 61CONSTANT: SOUND-BASE-HIT     2 
 62CONSTANT: SOUND-INVADER-HIT  3 
 63CONSTANT: SOUND-WALK1        4 
 64CONSTANT: SOUND-WALK2        5
 65CONSTANT: SOUND-WALK3        6 
 66CONSTANT: SOUND-WALK4        7 
 67CONSTANT: SOUND-UFO-HIT      8 
 68
 69: init-sound ( index cpu filename  -- )
 70  absolute-path swapd [ sounds>> nth AL_BUFFER ] dip
 71  create-buffer-from-wav set-source-param ; 
 72
 73: init-sounds ( cpu -- )
 74  init-openal
 75  [ 9 gen-sources swap sounds<< ] keep
 76  [ SOUND-SHOT        "vocab:space-invaders/resources/Shot.wav" init-sound ] keep 
 77  [ SOUND-UFO         "vocab:space-invaders/resources/Ufo.wav" init-sound ] keep 
 78  [ sounds>> SOUND-UFO swap nth AL_LOOPING AL_TRUE set-source-param ] keep
 79  [ SOUND-BASE-HIT    "vocab:space-invaders/resources/BaseHit.wav" init-sound ] keep 
 80  [ SOUND-INVADER-HIT "vocab:space-invaders/resources/InvHit.Wav" init-sound ] keep 
 81  [ SOUND-WALK1       "vocab:space-invaders/resources/Walk1.wav" init-sound ] keep 
 82  [ SOUND-WALK2       "vocab:space-invaders/resources/Walk2.wav" init-sound ] keep 
 83  [ SOUND-WALK3       "vocab:space-invaders/resources/Walk3.wav" init-sound ] keep 
 84  [ SOUND-WALK4       "vocab:space-invaders/resources/Walk4.wav" init-sound ] keep 
 85  [ SOUND-UFO-HIT    "vocab:space-invaders/resources/UfoHit.wav" init-sound ] keep
 86  f swap looping?<< ;
 87
 88: cpu-init ( cpu -- cpu )
 89  make-opengl-bitmap over bitmap<<
 90  [ init-sounds ] keep
 91  [ reset ] keep ;
 92
 93: <space-invaders> ( -- cpu )
 94  space-invaders new cpu-init ;
 95
 96: play-invaders-sound ( cpu sound -- )
 97  swap sounds>> nth source-play ;
 98
 99: stop-invaders-sound ( cpu sound -- )
100  swap sounds>> nth source-stop ;
101
102: read-port1 ( cpu -- byte )
103  #! Port 1 maps the keys for space invaders
104  #! Bit 0 = coin slot
105  #! Bit 1 = two players button
106  #! Bit 2 = one player button
107  #! Bit 4 = player one fire
108  #! Bit 5 = player one left
109  #! Bit 6 = player one right
110  [ port1>> dup 0xFE bitand ] keep 
111 port1<< ;
112
113: read-port2 ( cpu -- byte )
114  #! Port 2 maps player 2 controls and dip switches
115  #! Bit 0,1 = number of ships
116  #! Bit 2   = mode (1=easy, 0=hard)
117  #! Bit 4   = player two fire
118  #! Bit 5   = player two left
119  #! Bit 6   = player two right
120  #! Bit 7   = show or hide coin info
121  [ port2i>> 0x8F bitand ] keep 
122  port1>> 0x70 bitand bitor ;
123
124: read-port3 ( cpu -- byte )
125  #! Used to compute a special formula
126  [ port4hi>> 8 shift ] keep 
127  [ port4lo>> bitor ] keep 
128  port2o>> shift -8 shift 0xFF bitand ;
129
130M: space-invaders read-port ( port cpu -- byte )
131  #! Read a byte from the hardware port. 'port' should
132  #! be an 8-bit value.
133  swap {
134    { 1 [ read-port1 ] }
135    { 2 [ read-port2 ] }
136    { 3 [ read-port3 ] }
137    [ 2drop 0 ]
138  } case ;
139
140: write-port2 ( value cpu -- )
141  #! Setting this value affects the value read from port 3
142  port2o<< ;
143
144:: bit-newly-set? ( old-value new-value bit -- bool )
145  new-value bit bit? [ old-value bit bit? not ] dip and ;
146
147: port3-newly-set? ( new-value cpu bit -- bool )
148  [ port3o>> swap ] dip bit-newly-set? ;
149
150: port5-newly-set? ( new-value cpu bit -- bool )
151  [ port5o>> swap ] dip bit-newly-set? ;
152
153: write-port3 ( value cpu -- )
154  #! Connected to the sound hardware
155  #! Bit 0 = spaceship sound (looped)
156  #! Bit 1 = Shot 
157  #! Bit 2 = Your ship hit
158  #! Bit 3 = Invader hit
159  #! Bit 4 = Extended play sound
160  over 0 bit? over looping?>> not and [ 
161    dup SOUND-UFO play-invaders-sound 
162    t over looping?<<
163  ] when 
164  over 0 bit? not over looping?>> and [ 
165    dup SOUND-UFO stop-invaders-sound 
166    f over looping?<<
167  ] when 
168  2dup 0 port3-newly-set? [ dup SOUND-UFO  play-invaders-sound ] when
169  2dup 1 port3-newly-set? [ dup SOUND-SHOT play-invaders-sound ] when
170  2dup 2 port3-newly-set? [ dup SOUND-BASE-HIT play-invaders-sound ] when
171  2dup 3 port3-newly-set? [ dup SOUND-INVADER-HIT play-invaders-sound ] when
172  port3o<< ;
173
174: write-port4 ( value cpu -- )
175  #! Affects the value returned by reading port 3
176  [ port4hi>> ] keep 
177  [ port4lo<< ] keep 
178  port4hi<< ;
179
180: write-port5 ( value cpu -- )
181  #! Plays sounds
182  #! Bit 0 = invaders sound 1
183  #! Bit 1 = invaders sound 2
184  #! Bit 2 = invaders sound 3
185  #! Bit 3 = invaders sound 4
186  #! Bit 4 = spaceship hit 
187  #! Bit 5 = amplifier enabled/disabled
188  2dup 0 port5-newly-set? [ dup SOUND-WALK1 play-invaders-sound ] when
189  2dup 1 port5-newly-set? [ dup SOUND-WALK2 play-invaders-sound ] when
190  2dup 2 port5-newly-set? [ dup SOUND-WALK3 play-invaders-sound ] when
191  2dup 3 port5-newly-set? [ dup SOUND-WALK4 play-invaders-sound ] when
192  2dup 4 port5-newly-set? [ dup SOUND-UFO-HIT play-invaders-sound ] when
193  port5o<< ;
194
195M: space-invaders write-port ( value port cpu -- )
196  #! Write a byte to the hardware port, where 'port' is
197  #! an 8-bit value.  
198  swap {
199    { 2 [ write-port2 ] }
200    { 3 [ write-port3 ] }
201    { 4 [ write-port4 ] }
202    { 5 [ write-port5 ] }
203    [ 3drop ]
204  } case ;
205
206M: space-invaders reset ( cpu -- )
207  dup call-next-method
208  0 >>port1
209  0 >>port2i
210  0 >>port2o
211  0 >>port3o
212  0 >>port4lo
213  0 >>port4hi
214  0 >>port5o 
215  drop ;
216
217: gui-step ( cpu -- )
218  [ read-instruction ] keep ! n cpu
219  over get-cycles over inc-cycles
220  [ swap instructions nth call( cpu -- ) ] keep  
221  [ pc>> 0xFFFF bitand ] keep 
222  pc<< ;
223
224: gui-frame/2 ( cpu -- )
225  [ gui-step ] keep
226  [ cycles>> ] keep
227  over 16667 < [ ! cycles cpu
228    nip gui-frame/2
229  ] [
230    [ [ 16667 - ] dip cycles<< ] keep
231    dup last-interrupt>> 0x10 = [
232      0x08 over last-interrupt<< 0x08 swap interrupt
233    ] [
234      0x10 over last-interrupt<< 0x10 swap interrupt
235    ] if     
236  ] if ;
237
238: gui-frame ( cpu -- )
239  dup gui-frame/2 gui-frame/2 ;
240
241: coin-down ( cpu -- )
242  [ port1>> 1 bitor ] keep port1<< ;
243
244: coin-up ( cpu --  )
245  [ port1>> 255 1 - bitand ] keep port1<< ;
246
247: player1-down ( cpu -- )
248  [ port1>> 4 bitor ] keep port1<< ;
249
250: player1-up ( cpu -- )
251  [ port1>> 255 4 - bitand ] keep port1<< ;
252
253: player2-down ( cpu -- )
254  [ port1>> 2 bitor ] keep port1<< ;
255
256: player2-up ( cpu -- )
257  [ port1>> 255 2 - bitand ] keep port1<< ;
258
259: fire-down ( cpu -- )
260  [ port1>> 0x10 bitor ] keep port1<< ;
261
262: fire-up ( cpu -- )
263  [ port1>> 255 0x10 - bitand ] keep port1<< ;
264
265: left-down ( cpu -- )
266  [ port1>> 0x20 bitor ] keep port1<< ;
267
268: left-up ( cpu -- )
269  [ port1>> 255 0x20 - bitand ] keep port1<< ;
270
271: right-down ( cpu -- )
272  [ port1>> 0x40 bitor ] keep port1<< ;
273
274: right-up ( cpu -- )
275  [ port1>> 255 0x40 - bitand ] keep port1<< ;
276
277
278TUPLE: invaders-gadget < gadget cpu quit? windowed? ;
279
280invaders-gadget H{
281    { T{ key-down f f "ESC" }    [ t over quit?<< dup windowed?>> [ close-window ] [ drop ] if ] }
282    { T{ key-down f f "BACKSPACE" } [ cpu>> coin-down ] }
283    { T{ key-up   f f "BACKSPACE" } [ cpu>> coin-up ] }
284    { T{ key-down f f "1" }         [ cpu>> player1-down ] }
285    { T{ key-up   f f "1" }         [ cpu>> player1-up ] }
286    { T{ key-down f f "2" }         [ cpu>> player2-down ] }
287    { T{ key-up   f f "2" }         [ cpu>> player2-up ] }
288    { T{ key-down f f "UP" }        [ cpu>> fire-down ] }
289    { T{ key-up   f f "UP" }        [ cpu>> fire-up ] }
290    { T{ key-down f f "LEFT" }      [ cpu>> left-down ] }
291    { T{ key-up   f f "LEFT" }      [ cpu>> left-up ] }
292    { T{ key-down f f "RIGHT" }     [ cpu>> right-down ] }
293    { T{ key-up   f f "RIGHT" }     [ cpu>> right-up ] }
294  } set-gestures 
295
296: <invaders-gadget> ( cpu -- gadget ) 
297  invaders-gadget  new
298      swap >>cpu
299      f >>quit? ;
300
301M: invaders-gadget pref-dim* drop { 224 256 } ;
302
303M: invaders-gadget draw-gadget* ( gadget -- )
304  0 0 glRasterPos2i
305  1.0 -1.0 glPixelZoom
306  [ 224 256 GL_RGB GL_UNSIGNED_BYTE ] dip
307  cpu>> bitmap>> glDrawPixels ;
308
309CONSTANT: black { 0 0 0 } 
310CONSTANT: white { 255 255 255 } 
311CONSTANT: green { 0 255 0 } 
312CONSTANT: red   { 255 0 0 } 
313
314: addr>xy ( addr -- point )
315  #! Convert video RAM address to base X Y value. point is a {x y}.
316  0x2400 - ! n
317  dup 0x1f bitand 8 * 255 swap - ! n y
318  swap -5 shift swap 2array ;
319
320: plot-bitmap-pixel ( bitmap point color -- )
321  #! point is a {x y}. color is a {r g b}.
322  set-bitmap-pixel ;
323
324: get-point-color ( point -- color )
325  #! Return the color to use for the given x/y position.
326  first2
327  {
328    { [ dup 184 238 between? pick 0 223 between? and ] [ 2drop green ] }
329    { [ dup 240 247 between? pick 16 133 between? and ] [ 2drop green ] }
330    { [ dup 247 215 - 247 184 - between? pick 0 223 between? and ] [ 2drop red ] }
331    [ 2drop white ]
332  } cond ;
333
334: plot-bitmap-bits ( bitmap point byte bit -- )
335  #! point is a {x y}.
336  [ first2 ] 2dip
337  dup swapd -1 * shift 1 bitand 0 =
338  [ - 2array ] dip
339  [ black ] [ dup get-point-color ] if
340  plot-bitmap-pixel ;
341
342: do-bitmap-update ( bitmap value addr -- )
343  addr>xy swap 
344  [ 0 plot-bitmap-bits ] 3keep
345  [ 1 plot-bitmap-bits ] 3keep
346  [ 2 plot-bitmap-bits ] 3keep
347  [ 3 plot-bitmap-bits ] 3keep
348  [ 4 plot-bitmap-bits ] 3keep
349  [ 5 plot-bitmap-bits ] 3keep
350  [ 6 plot-bitmap-bits ] 3keep
351  7 plot-bitmap-bits ;
352
353M: space-invaders update-video ( value addr cpu -- )  
354  over 0x2400 >= [
355    bitmap>> -rot do-bitmap-update
356  ] [
357    3drop
358  ] if ;
359
360: sync-frame ( micros -- micros )
361  #! Sleep until the time for the next frame arrives.
362  1000 60 / >fixnum + gmt timestamp>micros - dup 0 >
363  [ milliseconds threads:sleep ] [ drop threads:yield ] if gmt timestamp>micros ;
364
365: invaders-process ( micros gadget -- )
366  #! Run a space invaders gadget inside a 
367  #! concurrent process. Messages can be sent to
368  #! signal key presses, etc.
369  dup quit?>> [
370    2drop
371  ] [
372    [ sync-frame ] dip
373    [ cpu>> gui-frame ] keep
374    [ relayout-1 ] keep
375    invaders-process 
376  ] if ;
377
378M: invaders-gadget graft* ( gadget -- )
379  dup cpu>> init-sounds
380  f over quit?<<
381  [ gmt timestamp>micros swap invaders-process ] curry
382  "Space invaders" threads:spawn drop ;
383
384M: invaders-gadget ungraft* ( gadget -- )
385 t swap quit?<< ;
386
387: (run) ( title cpu rom-info -- )
388  over load-rom* <invaders-gadget> t >>windowed? swap open-window ;
389
390CONSTANT: rom-info {
391      { 0x0000 "invaders/invaders.h" }
392      { 0x0800 "invaders/invaders.g" }
393      { 0x1000 "invaders/invaders.f" }
394      { 0x1800 "invaders/invaders.e" }
395   }
396
397: run-invaders ( -- )  
398  [
399    "Space Invaders" <space-invaders> rom-info (run)
400  ] with-ui ;
401
402MAIN: run-invaders