extra/space-invaders/space-invaders.factor

   1 ! Copyright (C) 2006 Chris Double.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 !
   4 USING:
   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 ;
  30 QUALIFIED: threads
  31 QUALIFIED: system
  32 SPECIALIZED-ARRAY: uchar
  33 IN: space-invaders
  34
  35 TUPLE: space-invaders < cpu port1 port2i port2o port3o port4lo port4hi port5o bitmap sounds looping? ;
  36 CONSTANT: game-width 224
  37 CONSTANT: 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
  59 CONSTANT: SOUND-SHOT         0
  60 CONSTANT: SOUND-UFO          1
  61 CONSTANT: SOUND-BASE-HIT     2
  62 CONSTANT: SOUND-INVADER-HIT  3
  63 CONSTANT: SOUND-WALK1        4
  64 CONSTANT: SOUND-WALK2        5
  65 CONSTANT: SOUND-WALK3        6
  66 CONSTANT: SOUND-WALK4        7
  67 CONSTANT: 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
 130 M: 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
 195 M: 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
 206 M: 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
 278 TUPLE: invaders-gadget < gadget cpu quit? windowed? ;
 279
 280 invaders-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
 301 M: invaders-gadget pref-dim* drop { 224 256 } ;
 302
 303 M: 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
 309 CONSTANT: black { 0 0 0 }
 310 CONSTANT: white { 255 255 255 }
 311 CONSTANT: green { 0 255 0 }
 312 CONSTANT: 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
 353 M: 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
 378 M: 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
 384 M: 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
 390 CONSTANT: 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
 402 MAIN: run-invaders