unmaintained/space-invaders/space-invaders.factor

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