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