contrib/space-invaders/space-invaders.factor

   1 ! Copyright (C) 2006 Chris Double.
   2 !
   3 ! Redistribution and use in source and binary forms, with or without
   4 ! modification, are permitted provided that the following conditions are met:
   5 !
   6 ! 1. Redistributions of source code must retain the above copyright notice,
   7 !    this list of conditions and the following disclaimer.
   8 !
   9 ! 2. Redistributions in binary form must reproduce the above copyright notice,
  10 !    this list of conditions and the following disclaimer in the documentation
  11 !    and/or other materials provided with the distribution.
  12 !
  13 ! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
  14 ! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
  15 ! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
  16 ! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
  17 ! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
  18 ! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
  19 ! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  20 ! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
  21 ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
  22 ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  23 USING: alien cpu-8080 errors generic io kernel kernel-internals
  24 math namespaces sequences styles threads gadgets gadgets opengl arrays
  25 concurrency ;
  26 IN: space-invaders
  27
  28 TUPLE: space-invaders port1 port2i port2o port3o port4lo port4hi port5o bitmap ;
  29
  30 : dip ( x y quot -- y )
  31   #! Showing my Joy roots...
  32   swap >r call r> ; inline
  33
  34 : dipd ( x y z quot -- y z )
  35   #! Showing my Joy roots...
  36   -rot >r >r call r> r> ; inline
  37
  38 : game-width 224  ; inline
  39 : game-height 256 ; inline
  40
  41 : make-opengl-bitmap ( -- array )
  42   game-height game-width 3 * * "char" <c-array> ;
  43
  44 : bitmap-index ( point -- index )
  45   #! Point is a {x y}.
  46   first2 game-width 3 * * swap 3 * + ;
  47
  48 : set-bitmap-pixel ( color point array -- )
  49   #! 'color' is a {r g b}. Point is {x y}.
  50   [ bitmap-index ] dip ! color index array
  51   [ [ first ] dipd set-uchar-nth ] 3keep
  52   [ [ second ] dipd [ 1 + ] dip set-uchar-nth ] 3keep
  53   [ third ] dipd [ 2 + ] dip set-uchar-nth ;
  54
  55 : get-bitmap-pixel ( point array -- color )
  56   #! Point is a {x y}. color is a {r g b}
  57   [ bitmap-index ] dip
  58   [ uint-nth ] 2keep
  59   [ [ 1 + ] dip uchar-nth ] 2keep
  60   [ 2 + ] dip uchar-nth 3array ;
  61
  62 C: space-invaders ( -- cpu )
  63   [ <cpu> swap set-delegate ] keep
  64   [ make-opengl-bitmap swap set-space-invaders-bitmap ] keep
  65   [ reset ] keep ;
  66
  67 : read-port1 ( cpu -- byte )
  68   #! Port 1 maps the keys for space invaders
  69   #! Bit 0 = coin slot
  70   #! Bit 1 = two players button
  71   #! Bit 2 = one player button
  72   #! Bit 4 = player one fire
  73   #! Bit 5 = player one left
  74   #! Bit 6 = player one right
  75   [ space-invaders-port1 dup HEX: FE bitand ] keep
  76  set-space-invaders-port1 ;
  77
  78 : read-port2 ( cpu -- byte )
  79   #! Port 2 maps player 2 controls and dip switches
  80   #! Bit 0,1 = number of ships
  81   #! Bit 2   = mode (1=easy, 0=hard)
  82   #! Bit 4   = player two fire
  83   #! Bit 5   = player two left
  84   #! Bit 6   = player two right
  85   #! Bit 7   = show or hide coin info
  86   [ space-invaders-port2i HEX: 8F bitand ] keep
  87   space-invaders-port1 HEX: 70 bitand bitor ;
  88
  89 : read-port3 ( cpu -- byte )
  90   #! Used to compute a special formula
  91   [ space-invaders-port4hi 8 shift ] keep
  92   [ space-invaders-port4lo bitor ] keep
  93   space-invaders-port2o shift -8 shift HEX: FF bitand ;
  94
  95 M: space-invaders read-port ( port cpu -- byte )
  96   #! Read a byte from the hardware port. 'port' should
  97   #! be an 8-bit value.
  98   {
  99     { [ over 1 = ] [ nip read-port1 ] }
 100     { [ over 2 = ] [ nip read-port2 ] }
 101     { [ over 3 = ] [ nip read-port3 ] }
 102     { [ t ]        [ 2drop 0 ] }
 103   } cond ;
 104
 105 : write-port2 ( value cpu -- )
 106   #! Setting this value affects the value read from port 3
 107   set-space-invaders-port2o ;
 108
 109 : write-port3 ( value cpu -- )
 110   #! Connected to the sound hardware
 111   #! Bit 0 = spaceship sound (looped)
 112   #! Bit 1 = Shot
 113   #! Bit 2 = Your ship hit
 114   #! Bit 3 = Invader hit
 115   #! Bit 4 = Extended play sound
 116   set-space-invaders-port3o ;
 117
 118 : write-port4 ( value cpu -- )
 119   #! Affects the value returned by reading port 3
 120   [ space-invaders-port4hi ] keep
 121   [ set-space-invaders-port4lo ] keep
 122   set-space-invaders-port4hi ;
 123
 124 : write-port5 ( value cpu -- )
 125   #! Plays sounds
 126   #! Bit 0 = invaders sound 1
 127   #! Bit 1 = invaders sound 2
 128   #! Bit 2 = invaders sound 3
 129   #! Bit 3 = invaders sound 4
 130   #! Bit 4 = spaceship hit
 131   #! Bit 5 = amplifier enabled/disabled
 132   set-space-invaders-port5o ;
 133
 134 M: space-invaders write-port ( value port cpu -- )
 135   #! Write a byte to the hardware port, where 'port' is
 136   #! an 8-bit value.
 137   {
 138     { [ over 2 = ] [ nip write-port2 ] }
 139     { [ over 3 = ] [ nip write-port3 ] }
 140     { [ over 4 = ] [ nip write-port4 ] }
 141     { [ over 5 = ] [ nip write-port5 ] }
 142     { [ t ]        [ 3drop ] }
 143   } cond ;
 144
 145 M: space-invaders reset ( cpu -- )
 146   [ delegate reset ] keep
 147   [ 0 swap set-space-invaders-port1 ] keep
 148   [ 0 swap set-space-invaders-port2i ] keep
 149   [ 0 swap set-space-invaders-port2o ] keep
 150   [ 0 swap set-space-invaders-port3o ] keep
 151   [ 0 swap set-space-invaders-port4lo ] keep
 152   [ 0 swap set-space-invaders-port4hi ] keep
 153   0 swap set-space-invaders-port5o ;
 154
 155 : gui-step ( cpu -- )
 156   [ read-instruction ] keep ! n cpu
 157   over get-cycles over inc-cycles
 158   [ swap instructions dispatch ] keep
 159   [ cpu-pc HEX: FFFF bitand ] keep
 160   set-cpu-pc ;
 161
 162 : gui-frame/2 ( cpu -- )
 163   [ gui-step ] keep
 164   [ cpu-cycles ] keep
 165   over 16667 < [ ! cycles cpu
 166     nip gui-frame/2
 167   ] [
 168     [ >r 16667 - r> set-cpu-cycles ] keep
 169     dup cpu-last-interrupt HEX: 10 = [
 170       HEX: 08 over set-cpu-last-interrupt HEX: 08 swap interrupt
 171     ] [
 172       HEX: 10 over set-cpu-last-interrupt HEX: 10 swap interrupt
 173     ] if
 174   ] if ;
 175
 176 : gui-frame ( cpu -- )
 177   dup gui-frame/2 gui-frame/2 ;
 178
 179 : coin-down ( cpu -- )
 180   [ space-invaders-port1 1 bitor ] keep set-space-invaders-port1 ;
 181
 182 : coin-up ( cpu --  )
 183   [ space-invaders-port1 255 1 - bitand ] keep set-space-invaders-port1 ;
 184
 185 : player1-down ( cpu -- )
 186   [ space-invaders-port1 4 bitor ] keep set-space-invaders-port1 ;
 187
 188 : player1-up ( cpu -- )
 189   [ space-invaders-port1 255 4 - bitand ] keep set-space-invaders-port1 ;
 190
 191 : player2-down ( cpu -- )
 192   [ space-invaders-port1 2 bitor ] keep set-space-invaders-port1 ;
 193
 194 : player2-up ( cpu -- )
 195   [ space-invaders-port1 255 2 - bitand ] keep set-space-invaders-port1 ;
 196
 197 : fire-down ( cpu -- )
 198   [ space-invaders-port1 HEX: 10 bitor ] keep set-space-invaders-port1 ;
 199
 200 : fire-up ( cpu -- )
 201   [ space-invaders-port1 255 HEX: 10 - bitand ] keep set-space-invaders-port1 ;
 202
 203 : left-down ( cpu -- )
 204   [ space-invaders-port1 HEX: 20 bitor ] keep set-space-invaders-port1 ;
 205
 206 : left-up ( cpu -- )
 207   [ space-invaders-port1 255 HEX: 20 - bitand ] keep set-space-invaders-port1 ;
 208
 209 : right-down ( cpu -- )
 210   [ space-invaders-port1 HEX: 40 bitor ] keep set-space-invaders-port1 ;
 211
 212 : right-up ( cpu -- )
 213   [ space-invaders-port1 255 HEX: 40 - bitand ] keep set-space-invaders-port1 ;
 214
 215
 216 TUPLE: invaders-gadget cpu quit? ;
 217
 218 invaders-gadget H{
 219     { T{ key-down f f "ESCAPE" }    [ t swap set-invaders-gadget-quit? ] }
 220     { T{ key-down f f "BACKSPACE" } [ invaders-gadget-cpu coin-down ] }
 221     { T{ key-up   f f "BACKSPACE" } [ invaders-gadget-cpu coin-up ] }
 222     { T{ key-down f f "1" }         [ invaders-gadget-cpu player1-down ] }
 223     { T{ key-up   f f "1" }         [ invaders-gadget-cpu player1-up ] }
 224     { T{ key-down f f "2" }         [ invaders-gadget-cpu player2-down ] }
 225     { T{ key-up   f f "2" }         [ invaders-gadget-cpu player2-up ] }
 226     { T{ key-down f f "UP" }        [ invaders-gadget-cpu fire-down ] }
 227     { T{ key-up   f f "UP" }        [ invaders-gadget-cpu fire-up ] }
 228     { T{ key-down f f "LEFT" }      [ invaders-gadget-cpu left-down ] }
 229     { T{ key-up   f f "LEFT" }      [ invaders-gadget-cpu left-up ] }
 230     { T{ key-down f f "RIGHT" }     [ invaders-gadget-cpu right-down ] }
 231     { T{ key-up   f f "RIGHT" }     [ invaders-gadget-cpu right-up ] }
 232   } set-gestures
 233
 234 C: invaders-gadget ( cpu -- gadget )
 235   [ set-invaders-gadget-cpu ] keep
 236   [ f swap set-invaders-gadget-quit? ] keep
 237   [ delegate>gadget ] keep ;
 238
 239 M: invaders-gadget pref-dim* drop { 224 256 0 } ;
 240
 241 M: invaders-gadget draw-gadget* ( gadget -- )
 242   0 0 glRasterPos2i
 243   1.0 -1.0 glPixelZoom
 244   >r 224 256 GL_RGB GL_UNSIGNED_BYTE r>
 245   invaders-gadget-cpu space-invaders-bitmap glDrawPixels ;
 246
 247 : black { 0 0 0 } ;
 248 : white { 255 255 255 } ;
 249 : green { 0 255 0 } ;
 250 : red   { 255 0 0 } ;
 251
 252 : addr>xy ( addr -- point )
 253   #! Convert video RAM address to base X Y value. point is a {x y}.
 254   HEX: 2400 - ! n
 255   dup HEX: 1f bitand 8 * 255 swap - ! n y
 256   swap -5 shift swap 2array ;
 257
 258 : plot-bitmap-pixel ( bitmap point color -- )
 259   #! point is a {x y}. color is a {r g b}.
 260   swap rot set-bitmap-pixel ;
 261
 262 : within ( n a b -- bool )
 263   #! n >= a and n <= b
 264   rot tuck swap <= >r swap >= r> and ;
 265
 266 : get-point-color ( point -- color )
 267   #! Return the color to use for the given x/y position.
 268   first2
 269   {
 270     { [ dup 184 238 within pick 0 223 within and ] [ 2drop green ] }
 271     { [ dup 240 247 within pick 16 133 within and ] [ 2drop green ] }
 272     { [ dup 247 215 - 247 184 - within pick 0 223 within and ] [ 2drop red ] }
 273     { [ t ] [ 2drop white ] }
 274   } cond ;
 275
 276 : plot-bitmap-bits ( bitmap point byte bit -- )
 277   #! point is a {x y}.
 278   [ first2 ] dipd
 279   dup swapd -1 * shift 1 bitand 0 =
 280   [ - 2array ] dip
 281   [ black ] [ dup get-point-color ] if
 282   plot-bitmap-pixel ;
 283
 284 : do-bitmap-update ( bitmap value addr -- )
 285   addr>xy swap
 286   [ 0 plot-bitmap-bits ] 3keep
 287   [ 1 plot-bitmap-bits ] 3keep
 288   [ 2 plot-bitmap-bits ] 3keep
 289   [ 3 plot-bitmap-bits ] 3keep
 290   [ 4 plot-bitmap-bits ] 3keep
 291   [ 5 plot-bitmap-bits ] 3keep
 292   [ 6 plot-bitmap-bits ] 3keep
 293   7 plot-bitmap-bits ;
 294
 295 M: space-invaders update-video ( value addr cpu -- )
 296   over HEX: 2400 >= [
 297     space-invaders-bitmap -rot do-bitmap-update
 298   ] [
 299     3drop
 300   ] if ;
 301
 302 : sync-frame ( millis -- millis )
 303   #! Sleep until the time for the next frame arrives.
 304   1000 60 / >fixnum + millis - dup 0 >
 305   [ sleep ] [ drop yield ] if millis ;
 306
 307 : invaders-process ( millis gadget -- )
 308   #! Run a space invaders gadget inside a
 309   #! concurrent process. Messages can be sent to
 310   #! signal key presses, etc.
 311   dup invaders-gadget-quit? [
 312     [ sync-frame ] dip
 313     [ invaders-gadget-cpu gui-frame ] keep
 314     [ relayout-1 ] keep
 315     invaders-process
 316   ] unless ;
 317
 318 M: invaders-gadget graft* ( gadget -- )
 319  [ f swap set-invaders-gadget-quit? ] keep
 320  [ millis swap invaders-process ] spawn 2drop ;
 321
 322 M: invaders-gadget ungraft* ( gadget -- )
 323  t swap set-invaders-gadget-quit? ;
 324
 325 : run ( -- gadget )
 326   <space-invaders> "invaders.rom" over load-rom <invaders-gadget>
 327   [ "Space Invaders" open-titled-window ] keep ;