+++ /dev/null
-Chris Double
+++ /dev/null
-! Copyright (C) 2007 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.syntax help.markup cpu.8080.emulator ;
-IN: balloon-bomber
-
-HELP: run-balloon
-{ $description
-"Run the Balloon Bomber emulator in a new window." $nl
-{ $link rom-root } " must be set to the directory containing the "
-"location of the Balloon Bomber ROM files. See "
-{ $link { "balloon-bomber" "balloon-bomber" } } " for details."
-} ;
-
-ARTICLE: "balloon-bomber" "Balloon Bomber Emulator"
-"Provides an emulation of the original 8080 Arcade Game 'Balloon Bomber'." $nl
-"More information on the arcade game can be obtained from " { $url "https://www.emuparadise.me/M.A.M.E._-_Multiple_Arcade_Machine_Emulator_ROMs/Balloon_Bomber/11301" } "." $nl
-"To play the game you need the ROM files for the arcade game. They should "
-"be placed in a directory called 'ballbomb' in the location specified by "
-"the variable " { $link rom-root } ". The specific files needed are:"
-{ $list
- "ballbomb/tn01"
- "ballbomb/tn02"
- "ballbomb/tn03"
- "ballbomb/tn04"
- "ballbomb/tn05-1"
-}
-"These are the same ROM files as used by MAME. To run the game use the "
-{ $link run-balloon } " word." $nl
-"Keys:"
-{ $table
- { "Backspace" "Insert Coin" }
- { "1" "1 Player" }
- { "2" "2 Player" }
- { "Left" "Move Left" }
- { "Right" "Move Right" }
- { "Up" "Fire" }
-}
-"If you save the Factor image while a game is running, when you restart "
-"the image the game continues where it left off." ;
-
-ABOUT: "balloon-bomber"
+++ /dev/null
-! Copyright (C) 2007 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-!
-! Balloon Bomber: https://www.emuparadise.me/M.A.M.E._-_Multiple_Arcade_Machine_Emulator_ROMs/Balloon_Bomber/11301
-USING: kernel space-invaders ui ;
-IN: balloon-bomber
-
-TUPLE: balloon-bomber < space-invaders ;
-
-: <balloon-bomber> ( -- cpu )
- balloon-bomber new cpu-init ;
-
-CONSTANT: rom-info {
- { 0x0000 "ballbomb/tn01" }
- { 0x0800 "ballbomb/tn02" }
- { 0x1000 "ballbomb/tn03" }
- { 0x1800 "ballbomb/tn04" }
- { 0x4000 "ballbomb/tn05-1" }
-}
-
-: run-balloon ( -- )
- [
- "Balloon Bomber" <balloon-bomber> rom-info run-rom
- ] with-ui ;
-
-MAIN: run-balloon
+++ /dev/null
-Intel 8080-based Balloon Bomber arcade machine emulator
+++ /dev/null
-demos
-games
-applications
+++ /dev/null
-Chris Double
+++ /dev/null
-! Copyright (C) 2007 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.syntax help.markup cpu.8080.emulator ;
-IN: lunar-rescue
-
-HELP: run-lunar
-{ $description
-"Run the Lunar Rescue emulator in a new window." $nl
-{ $link rom-root } " must be set to the directory containing the "
-"location of the Lunar Rescue ROM files. See "
-{ $link { "lunar-rescue" "lunar-rescue" } } " for details."
-} ;
-
-ARTICLE: "lunar-rescue" "Lunar Rescue Emulator"
-"Provides an emulation of the original 8080 Arcade Game 'Lunar Rescue'." $nl
-"More information on the arcade game can be obtained from " { $url "https://www.emuparadise.me/M.A.M.E._-_Multiple_Arcade_Machine_Emulator_ROMs/Lunar_Rescue/14294" } "." $nl
-"To play the game you need the ROM files for the arcade game. They should "
-"be placed in a directory called " { $snippet "lrescue" } " in the location specified by "
-"the variable " { $link rom-root } ". The specific files needed are:"
-{ $list
- "lrescue/lrescue.1"
- "lrescue/lrescue.2"
- "lrescue/lrescue.3"
- "lrescue/lrescue.4"
- "lrescue/lrescue.5"
- "lrescue/lrescue.6"
-}
-"These are the same ROM files as used by MAME. To run the game use the "
-{ $link run-lunar } " word." $nl
-"Keys:"
-{ $table
- { "Backspace" "Insert Coin" }
- { "1" "1 Player" }
- { "2" "2 Player" }
- { "Left" "Move Left" }
- { "Right" "Move Right" }
- { "Up" "Fire or apply thrusters" }
-}
-"If you save the Factor image while a game is running, when you restart "
-"the image the game continues where it left off." ;
-
-ABOUT: "lunar-rescue"
+++ /dev/null
-! Copyright (C) 2007 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-!
-! Lunar Rescue: https://www.emuparadise.me/M.A.M.E._-_Multiple_Arcade_Machine_Emulator_ROMs/Lunar_Rescue/14294
-USING: kernel space-invaders ui ;
-IN: lunar-rescue
-
-TUPLE: lunar-rescue < space-invaders ;
-
-: <lunar-rescue> ( -- cpu )
- lunar-rescue new cpu-init ;
-
-CONSTANT: rom-info {
- { 0x0000 "lrescue/lrescue.1" }
- { 0x0800 "lrescue/lrescue.2" }
- { 0x1000 "lrescue/lrescue.3" }
- { 0x1800 "lrescue/lrescue.4" }
- { 0x4000 "lrescue/lrescue.5" }
- { 0x4800 "lrescue/lrescue.6" }
-}
-
-: run-lunar ( -- )
- [
- "Lunar Rescue" <lunar-rescue> rom-info run-rom
- ] with-ui ;
-
-MAIN: run-lunar
+++ /dev/null
-Intel 8080-based Lunar Rescue arcade machine emulator
+++ /dev/null
-games
-applications
--- /dev/null
+Chris Double
--- /dev/null
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.syntax help.markup cpu.8080.emulator ;
+IN: roms.balloon-bomber
+
+HELP: run-balloon
+{ $description
+"Run the Balloon Bomber emulator in a new window." $nl
+{ $link rom-root } " must be set to the directory containing the "
+"location of the Balloon Bomber ROM files. See "
+{ $link "balloon-bomber" } " for details."
+} ;
+
+ARTICLE: "balloon-bomber" "Balloon Bomber Emulator"
+"Provides an emulation of the original 8080 Arcade Game 'Balloon Bomber'." $nl
+"More information on the arcade game can be obtained from " { $url "https://www.emuparadise.me/M.A.M.E._-_Multiple_Arcade_Machine_Emulator_ROMs/Balloon_Bomber/11301" } "." $nl
+"To play the game you need the ROM files for the arcade game. They should "
+"be placed in a directory called 'ballbomb' in the location specified by "
+"the variable " { $link rom-root } ". The specific files needed are:"
+{ $list
+ "ballbomb/tn01"
+ "ballbomb/tn02"
+ "ballbomb/tn03"
+ "ballbomb/tn04"
+ "ballbomb/tn05-1"
+}
+"These are the same ROM files as used by MAME. To run the game use the "
+{ $link run-balloon } " word." $nl
+"Keys:"
+{ $table
+ { "Backspace" "Insert Coin" }
+ { "1" "1 Player" }
+ { "2" "2 Player" }
+ { "Left" "Move Left" }
+ { "Right" "Move Right" }
+ { "Up" "Fire" }
+}
+"If you save the Factor image while a game is running, when you restart "
+"the image the game continues where it left off." ;
+
+ABOUT: "balloon-bomber"
--- /dev/null
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+!
+! Balloon Bomber: https://www.emuparadise.me/M.A.M.E._-_Multiple_Arcade_Machine_Emulator_ROMs/Balloon_Bomber/11301
+USING: kernel roms.space-invaders ui ;
+IN: roms.balloon-bomber
+
+TUPLE: balloon-bomber < space-invaders ;
+
+: <balloon-bomber> ( -- cpu )
+ balloon-bomber new cpu-init ;
+
+CONSTANT: rom-info {
+ { 0x0000 "ballbomb/tn01" }
+ { 0x0800 "ballbomb/tn02" }
+ { 0x1000 "ballbomb/tn03" }
+ { 0x1800 "ballbomb/tn04" }
+ { 0x4000 "ballbomb/tn05-1" }
+}
+
+: run-balloon ( -- )
+ [
+ "Balloon Bomber" <balloon-bomber> rom-info run-rom
+ ] with-ui ;
+
+MAIN: run-balloon
--- /dev/null
+Intel 8080-based Balloon Bomber arcade machine emulator
--- /dev/null
+demos
+games
+applications
--- /dev/null
+Chris Double
--- /dev/null
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.syntax help.markup cpu.8080.emulator ;
+IN: roms.lunar-rescue
+
+HELP: run-lunar
+{ $description
+"Run the Lunar Rescue emulator in a new window." $nl
+{ $link rom-root } " must be set to the directory containing the "
+"location of the Lunar Rescue ROM files. See "
+{ $link { "lunar-rescue" "lunar-rescue" } } " for details."
+} ;
+
+ARTICLE: "lunar-rescue" "Lunar Rescue Emulator"
+"Provides an emulation of the original 8080 Arcade Game 'Lunar Rescue'." $nl
+"More information on the arcade game can be obtained from " { $url "https://www.emuparadise.me/M.A.M.E._-_Multiple_Arcade_Machine_Emulator_ROMs/Lunar_Rescue/14294" } "." $nl
+"To play the game you need the ROM files for the arcade game. They should "
+"be placed in a directory called " { $snippet "lrescue" } " in the location specified by "
+"the variable " { $link rom-root } ". The specific files needed are:"
+{ $list
+ "lrescue/lrescue.1"
+ "lrescue/lrescue.2"
+ "lrescue/lrescue.3"
+ "lrescue/lrescue.4"
+ "lrescue/lrescue.5"
+ "lrescue/lrescue.6"
+}
+"These are the same ROM files as used by MAME. To run the game use the "
+{ $link run-lunar } " word." $nl
+"Keys:"
+{ $table
+ { "Backspace" "Insert Coin" }
+ { "1" "1 Player" }
+ { "2" "2 Player" }
+ { "Left" "Move Left" }
+ { "Right" "Move Right" }
+ { "Up" "Fire or apply thrusters" }
+}
+"If you save the Factor image while a game is running, when you restart "
+"the image the game continues where it left off." ;
+
+ABOUT: "lunar-rescue"
--- /dev/null
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+!
+! Lunar Rescue: https://www.emuparadise.me/M.A.M.E._-_Multiple_Arcade_Machine_Emulator_ROMs/Lunar_Rescue/14294
+USING: kernel roms.space-invaders ui ;
+IN: roms.lunar-rescue
+
+TUPLE: lunar-rescue < space-invaders ;
+
+: <lunar-rescue> ( -- cpu )
+ lunar-rescue new cpu-init ;
+
+CONSTANT: rom-info {
+ { 0x0000 "lrescue/lrescue.1" }
+ { 0x0800 "lrescue/lrescue.2" }
+ { 0x1000 "lrescue/lrescue.3" }
+ { 0x1800 "lrescue/lrescue.4" }
+ { 0x4000 "lrescue/lrescue.5" }
+ { 0x4800 "lrescue/lrescue.6" }
+}
+
+: run-lunar ( -- )
+ [
+ "Lunar Rescue" <lunar-rescue> rom-info run-rom
+ ] with-ui ;
+
+MAIN: run-lunar
--- /dev/null
+Intel 8080-based Lunar Rescue arcade machine emulator
--- /dev/null
+games
+applications
--- /dev/null
+Chris Double
--- /dev/null
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.syntax help.markup cpu.8080.emulator ;
+IN: roms.space-invaders
+
+HELP: run-invaders
+{ $description
+"Run the Space Invaders emulator in a new window." $nl
+{ $link rom-root } " must be set to the directory containing the "
+"location of the Space Invaders ROM files. See "
+{ $link "space-invaders" } " for details."
+} ;
+
+ARTICLE: "space-invaders" "Space Invaders Emulator"
+"Provides an emulation of the original 8080 Arcade Game 'Space Invaders'." $nl
+"More information on the arcade game can be obtained from " { $url "http://www.emuparadise.me/M.A.M.E._-_Multiple_Arcade_Machine_Emulator_ROMs/Space_Invaders_--_Space_Invaders_M/13774" } "." $nl
+"To play the game you need the ROM files for the arcade game. They should "
+"be placed in a directory called 'invaders' in the location specified by "
+"the variable " { $link rom-root } ". The specific files needed are:"
+{ $list
+ "invaders/invaders.e"
+ "invaders/invaders.f"
+ "invaders/invaders.g"
+ "invaders/invaders.h"
+}
+"These are the same ROM files as used by MAME. To run the game use the "
+{ $link run-invaders } " word." $nl
+"Keys:"
+{ $table
+ { "Backspace" "Insert Coin" }
+ { "1" "1 Player" }
+ { "2" "2 Player" }
+ { "Left" "Move Left" }
+ { "Right" "Move Right" }
+ { "Up" "Fire" }
+}
+"If you save the Factor image while a game is running, when you restart "
+"the image the game continues where it left off." ;
+
+ABOUT: "space-invaders"
--- /dev/null
+! Copyright (C) 2006 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+!
+! Space Invaders: http://www.emuparadise.me/M.A.M.E._-_Multiple_Arcade_Machine_Emulator_ROMs/Space_Invaders_--_Space_Invaders_M/13774
+USING: accessors alien.c-types alien.data arrays
+combinators cpu.8080 cpu.8080.emulator io.pathnames kernel
+locals math math.order openal openal.alut opengl.gl sequences
+specialized-arrays ui ui.gadgets ui.gestures ui.render ;
+QUALIFIED: threads
+QUALIFIED: system
+SPECIALIZED-ARRAY: uchar
+IN: roms.space-invaders
+
+TUPLE: space-invaders < cpu
+ port1 port2i port2o port3o port4lo port4hi port5o
+ bitmap sounds looping? ;
+
+CONSTANT: game-width 224
+CONSTANT: game-height 256
+
+: make-opengl-bitmap ( -- array )
+ game-height game-width 3 * * uchar <c-array> ;
+
+: bitmap-index ( point -- index )
+ ! Point is a {x y}.
+ first2 game-width 3 * * swap 3 * + ;
+
+:: set-bitmap-pixel ( bitmap point color -- )
+ point bitmap-index :> index
+ color first index bitmap set-nth
+ color second index 1 + bitmap set-nth
+ color third index 2 + bitmap set-nth ;
+
+: get-bitmap-pixel ( point array -- color )
+ ! Point is a {x y}. color is a {r g b}
+ [ bitmap-index ] dip
+ [ nth ]
+ [ [ 1 + ] dip nth ]
+ [ [ 2 + ] dip nth ] 2tri 3array ;
+
+CONSTANT: SOUND-SHOT 0
+CONSTANT: SOUND-UFO 1
+CONSTANT: SOUND-BASE-HIT 2
+CONSTANT: SOUND-INVADER-HIT 3
+CONSTANT: SOUND-WALK1 4
+CONSTANT: SOUND-WALK2 5
+CONSTANT: SOUND-WALK3 6
+CONSTANT: SOUND-WALK4 7
+CONSTANT: SOUND-UFO-HIT 8
+
+: init-sound ( index cpu filename -- )
+ absolute-path swapd [ sounds>> nth AL_BUFFER ] dip
+ create-buffer-from-wav set-source-param ;
+
+: init-sounds ( cpu -- )
+ init-openal {
+ [ 9 gen-sources swap sounds<< ]
+ [ SOUND-SHOT "vocab:roms/space-invaders/resources/Shot.wav" init-sound ]
+ [ SOUND-UFO "vocab:roms/space-invaders/resources/Ufo.wav" init-sound ]
+ [ sounds>> SOUND-UFO swap nth AL_LOOPING AL_TRUE set-source-param ]
+ [ SOUND-BASE-HIT "vocab:roms/space-invaders/resources/BaseHit.wav" init-sound ]
+ [ SOUND-INVADER-HIT "vocab:roms/space-invaders/resources/InvHit.Wav" init-sound ]
+ [ SOUND-WALK1 "vocab:roms/space-invaders/resources/Walk1.wav" init-sound ]
+ [ SOUND-WALK2 "vocab:roms/space-invaders/resources/Walk2.wav" init-sound ]
+ [ SOUND-WALK3 "vocab:roms/space-invaders/resources/Walk3.wav" init-sound ]
+ [ SOUND-WALK4 "vocab:roms/space-invaders/resources/Walk4.wav" init-sound ]
+ [ SOUND-UFO-HIT "vocab:roms/space-invaders/resources/UfoHit.wav" init-sound ]
+ [ f swap looping?<< ]
+ } cleave ;
+
+: cpu-init ( cpu -- cpu )
+ make-opengl-bitmap >>bitmap
+ [ init-sounds ] keep
+ [ reset ] keep ;
+
+: <space-invaders> ( -- cpu )
+ space-invaders new cpu-init ;
+
+: play-invaders-sound ( cpu sound -- )
+ swap sounds>> nth source-play ;
+
+: stop-invaders-sound ( cpu sound -- )
+ swap sounds>> nth source-stop ;
+
+: read-port1 ( cpu -- byte )
+ ! Port 1 maps the keys for space invaders
+ ! Bit 0 = coin slot
+ ! Bit 1 = two players button
+ ! Bit 2 = one player button
+ ! Bit 4 = player one fire
+ ! Bit 5 = player one left
+ ! Bit 6 = player one right
+ [ dup 0xFE bitand ] change-port1 drop ;
+
+: read-port2 ( cpu -- byte )
+ ! Port 2 maps player 2 controls and dip switches
+ ! Bit 0,1 = number of ships
+ ! Bit 2 = mode (1=easy, 0=hard)
+ ! Bit 4 = player two fire
+ ! Bit 5 = player two left
+ ! Bit 6 = player two right
+ ! Bit 7 = show or hide coin info
+ [ port2i>> 0x8F bitand ]
+ [ port1>> 0x70 bitand bitor ] bi ;
+
+: read-port3 ( cpu -- byte )
+ ! Used to compute a special formula
+ [ port4hi>> 8 shift ] keep
+ [ port4lo>> bitor ] keep
+ port2o>> shift -8 shift 0xFF bitand ;
+
+M: space-invaders read-port
+ ! Read a byte from the hardware port. 'port' should
+ ! be an 8-bit value.
+ swap {
+ { 1 [ read-port1 ] }
+ { 2 [ read-port2 ] }
+ { 3 [ read-port3 ] }
+ [ 2drop 0 ]
+ } case ;
+
+: write-port2 ( value cpu -- )
+ ! Setting this value affects the value read from port 3
+ port2o<< ;
+
+:: bit-newly-set? ( old-value new-value bit -- bool )
+ old-value bit bit? not new-value bit bit? and ;
+
+: port3-newly-set? ( new-value cpu bit -- bool )
+ [ port3o>> swap ] dip bit-newly-set? ;
+
+: port5-newly-set? ( new-value cpu bit -- bool )
+ [ port5o>> swap ] dip bit-newly-set? ;
+
+: write-port3 ( value cpu -- )
+ ! Connected to the sound hardware
+ ! Bit 0 = spaceship sound (looped)
+ ! Bit 1 = Shot
+ ! Bit 2 = Your ship hit
+ ! Bit 3 = Invader hit
+ ! Bit 4 = Extended play sound
+ over 0 bit? [
+ dup looping?>> [
+ dup SOUND-UFO play-invaders-sound
+ t >>looping?
+ ] unless
+ ] [
+ dup looping?>> [
+ dup SOUND-UFO stop-invaders-sound
+ f >>looping?
+ ] when
+ ] if
+ 2dup 0 port3-newly-set? [ dup SOUND-UFO play-invaders-sound ] when
+ 2dup 1 port3-newly-set? [ dup SOUND-SHOT play-invaders-sound ] when
+ 2dup 2 port3-newly-set? [ dup SOUND-BASE-HIT play-invaders-sound ] when
+ 2dup 3 port3-newly-set? [ dup SOUND-INVADER-HIT play-invaders-sound ] when
+ port3o<< ;
+
+: write-port4 ( value cpu -- )
+ ! Affects the value returned by reading port 3
+ [ port4hi>> ] [ port4lo<< ] [ port4hi<< ] tri ;
+
+: write-port5 ( value cpu -- )
+ ! Plays sounds
+ ! Bit 0 = invaders sound 1
+ ! Bit 1 = invaders sound 2
+ ! Bit 2 = invaders sound 3
+ ! Bit 3 = invaders sound 4
+ ! Bit 4 = spaceship hit
+ ! Bit 5 = amplifier enabled/disabled
+ 2dup 0 port5-newly-set? [ dup SOUND-WALK1 play-invaders-sound ] when
+ 2dup 1 port5-newly-set? [ dup SOUND-WALK2 play-invaders-sound ] when
+ 2dup 2 port5-newly-set? [ dup SOUND-WALK3 play-invaders-sound ] when
+ 2dup 3 port5-newly-set? [ dup SOUND-WALK4 play-invaders-sound ] when
+ 2dup 4 port5-newly-set? [ dup SOUND-UFO-HIT play-invaders-sound ] when
+ port5o<< ;
+
+M: space-invaders write-port
+ ! Write a byte to the hardware port, where 'port' is
+ ! an 8-bit value.
+ swap {
+ { 2 [ write-port2 ] }
+ { 3 [ write-port3 ] }
+ { 4 [ write-port4 ] }
+ { 5 [ write-port5 ] }
+ [ 3drop ]
+ } case ;
+
+M: space-invaders reset
+ dup call-next-method
+ 0 >>port1
+ 0 >>port2i
+ 0 >>port2o
+ 0 >>port3o
+ 0 >>port4lo
+ 0 >>port4hi
+ 0 >>port5o
+ drop ;
+
+: gui-step ( cpu -- )
+ [ read-instruction ] keep ! n cpu
+ over get-cycles over inc-cycles
+ [ swap instructions nth call( cpu -- ) ] keep
+ [ pc>> 0xFFFF bitand ] keep
+ pc<< ;
+
+: gui-frame/2 ( cpu -- )
+ [ gui-step ] keep
+ [ cycles>> ] keep
+ over 16667 < [ ! cycles cpu
+ nip gui-frame/2
+ ] [
+ [ [ 16667 - ] dip cycles<< ] keep
+ dup last-interrupt>> 0x10 = [
+ 0x08 >>last-interrupt 0x08 swap interrupt
+ ] [
+ 0x10 >>last-interrupt 0x10 swap interrupt
+ ] if
+ ] if ;
+
+: gui-frame ( cpu -- )
+ dup gui-frame/2 gui-frame/2 ;
+
+: coin-down ( cpu -- )
+ [ 1 bitor ] change-port1 drop ;
+
+: coin-up ( cpu -- )
+ [ 255 1 - bitand ] change-port1 drop ;
+
+: player1-down ( cpu -- )
+ [ 4 bitor ] change-port1 drop ;
+
+: player1-up ( cpu -- )
+ [ 255 4 - bitand ] change-port1 drop ;
+
+: player2-down ( cpu -- )
+ [ 2 bitor ] change-port1 drop ;
+
+: player2-up ( cpu -- )
+ [ 255 2 - bitand ] change-port1 drop ;
+
+: fire-down ( cpu -- )
+ [ 0x10 bitor ] change-port1 drop ;
+
+: fire-up ( cpu -- )
+ [ 255 0x10 - bitand ] change-port1 drop ;
+
+: left-down ( cpu -- )
+ [ 0x20 bitor ] change-port1 drop ;
+
+: left-up ( cpu -- )
+ [ 255 0x20 - bitand ] change-port1 drop ;
+
+: right-down ( cpu -- )
+ [ 0x40 bitor ] change-port1 drop ;
+
+: right-up ( cpu -- )
+ [ 255 0x40 - bitand ] change-port1 drop ;
+
+TUPLE: invaders-gadget < gadget cpu quit? windowed? ;
+
+invaders-gadget H{
+ { T{ key-down f f "ESC" } [ t >>quit? dup windowed?>> [ close-window ] [ drop ] if ] }
+ { T{ key-down f f "BACKSPACE" } [ cpu>> coin-down ] }
+ { T{ key-up f f "BACKSPACE" } [ cpu>> coin-up ] }
+ { T{ key-down f f "1" } [ cpu>> player1-down ] }
+ { T{ key-up f f "1" } [ cpu>> player1-up ] }
+ { T{ key-down f f "2" } [ cpu>> player2-down ] }
+ { T{ key-up f f "2" } [ cpu>> player2-up ] }
+ { T{ key-down f f "UP" } [ cpu>> fire-down ] }
+ { T{ key-up f f "UP" } [ cpu>> fire-up ] }
+ { T{ key-down f f "LEFT" } [ cpu>> left-down ] }
+ { T{ key-up f f "LEFT" } [ cpu>> left-up ] }
+ { T{ key-down f f "RIGHT" } [ cpu>> right-down ] }
+ { T{ key-up f f "RIGHT" } [ cpu>> right-up ] }
+} set-gestures
+
+: <invaders-gadget> ( cpu -- gadget )
+ invaders-gadget new
+ swap >>cpu
+ f >>quit? ;
+
+M: invaders-gadget pref-dim* drop { 224 256 } ;
+
+M: invaders-gadget draw-gadget*
+ 0 0 glRasterPos2i
+ 1.0 -1.0 glPixelZoom
+ [ 224 256 GL_RGB GL_UNSIGNED_BYTE ] dip
+ cpu>> bitmap>> glDrawPixels ;
+
+CONSTANT: black { 0 0 0 }
+CONSTANT: white { 255 255 255 }
+CONSTANT: green { 0 255 0 }
+CONSTANT: red { 255 0 0 }
+
+: addr>xy ( addr -- point )
+ ! Convert video RAM address to base X Y value. point is a {x y}.
+ 0x2400 - ! n
+ dup 0x1f bitand 8 * 255 swap - ! n y
+ swap -5 shift swap 2array ;
+
+: plot-bitmap-pixel ( bitmap point color -- )
+ ! point is a {x y}. color is a {r g b}.
+ set-bitmap-pixel ;
+
+: get-point-color ( point -- color )
+ ! Return the color to use for the given x/y position.
+ first2
+ {
+ { [ dup 184 238 between? pick 0 223 between? and ] [ 2drop green ] }
+ { [ dup 240 247 between? pick 16 133 between? and ] [ 2drop green ] }
+ { [ dup 247 215 - 247 184 - between? pick 0 223 between? and ] [ 2drop red ] }
+ [ 2drop white ]
+ } cond ;
+
+: plot-bitmap-bits ( bitmap point byte bit -- )
+ ! point is a {x y}.
+ [ first2 ] 2dip
+ dup swapd -1 * shift 1 bitand 0 =
+ [ - 2array ] dip
+ [ black ] [ dup get-point-color ] if
+ plot-bitmap-pixel ;
+
+: do-bitmap-update ( bitmap value addr -- )
+ addr>xy swap 8 <iota> [ plot-bitmap-bits ] with with with each ;
+
+M: space-invaders update-video
+ over 0x2400 >= [
+ bitmap>> -rot do-bitmap-update
+ ] [
+ 3drop
+ ] if ;
+
+: sync-frame ( micros -- micros )
+ ! Sleep until the time for the next frame arrives.
+ 16,667 + system:nano-count - dup 0 >
+ [ 1,000 * threads:sleep ] [ drop threads:yield ] if
+ system:nano-count ;
+
+: invaders-process ( micros gadget -- )
+ ! Run a space invaders gadget inside a
+ ! concurrent process. Messages can be sent to
+ ! signal key presses, etc.
+ dup quit?>> [
+ exit-openal 2drop
+ ] [
+ [ sync-frame ] dip {
+ [ cpu>> gui-frame ]
+ [ relayout-1 ]
+ [ invaders-process ]
+ } cleave
+ ] if ;
+
+M: invaders-gadget graft*
+ dup cpu>> init-sounds
+ f >>quit?
+ [ system:nano-count swap invaders-process ] curry
+ "Space invaders" threads:spawn drop ;
+
+M: invaders-gadget ungraft*
+ t swap quit?<< ;
+
+: run-rom ( title cpu rom-info -- )
+ over load-rom* <invaders-gadget> t >>windowed? swap open-window ;
+
+CONSTANT: rom-info {
+ { 0x0000 "invaders/invaders.h" }
+ { 0x0800 "invaders/invaders.g" }
+ { 0x1000 "invaders/invaders.f" }
+ { 0x1800 "invaders/invaders.e" }
+}
+
+: run-invaders ( -- )
+ [
+ "Space Invaders" <space-invaders> rom-info run-rom
+ ] with-ui ;
+
+MAIN: run-invaders
--- /dev/null
+Intel 8080-based Space Invaders arcade machine emulator
--- /dev/null
+demos
+games
+applications
+++ /dev/null
-Chris Double
+++ /dev/null
-! Copyright (C) 2007 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.syntax help.markup cpu.8080.emulator ;
-IN: space-invaders
-
-HELP: run-invaders
-{ $description
-"Run the Space Invaders emulator in a new window." $nl
-{ $link rom-root } " must be set to the directory containing the "
-"location of the Space Invaders ROM files. See "
-{ $link "space-invaders" } " for details."
-} ;
-
-ARTICLE: "space-invaders" "Space Invaders Emulator"
-"Provides an emulation of the original 8080 Arcade Game 'Space Invaders'." $nl
-"More information on the arcade game can be obtained from " { $url "http://www.emuparadise.me/M.A.M.E._-_Multiple_Arcade_Machine_Emulator_ROMs/Space_Invaders_--_Space_Invaders_M/13774" } "." $nl
-"To play the game you need the ROM files for the arcade game. They should "
-"be placed in a directory called 'invaders' in the location specified by "
-"the variable " { $link rom-root } ". The specific files needed are:"
-{ $list
- "invaders/invaders.e"
- "invaders/invaders.f"
- "invaders/invaders.g"
- "invaders/invaders.h"
-}
-"These are the same ROM files as used by MAME. To run the game use the "
-{ $link run-invaders } " word." $nl
-"Keys:"
-{ $table
- { "Backspace" "Insert Coin" }
- { "1" "1 Player" }
- { "2" "2 Player" }
- { "Left" "Move Left" }
- { "Right" "Move Right" }
- { "Up" "Fire" }
-}
-"If you save the Factor image while a game is running, when you restart "
-"the image the game continues where it left off." ;
-
-ABOUT: "space-invaders"
+++ /dev/null
-! Copyright (C) 2006 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-!
-! Space Invaders: http://www.emuparadise.me/M.A.M.E._-_Multiple_Arcade_Machine_Emulator_ROMs/Space_Invaders_--_Space_Invaders_M/13774
-USING: accessors alien.c-types alien.data arrays
-combinators cpu.8080 cpu.8080.emulator io.pathnames kernel
-locals math math.order openal openal.alut opengl.gl sequences
-specialized-arrays ui ui.gadgets ui.gestures ui.render ;
-QUALIFIED: threads
-QUALIFIED: system
-SPECIALIZED-ARRAY: uchar
-IN: space-invaders
-
-TUPLE: space-invaders < cpu
- port1 port2i port2o port3o port4lo port4hi port5o
- bitmap sounds looping? ;
-
-CONSTANT: game-width 224
-CONSTANT: game-height 256
-
-: make-opengl-bitmap ( -- array )
- game-height game-width 3 * * uchar <c-array> ;
-
-: bitmap-index ( point -- index )
- ! Point is a {x y}.
- first2 game-width 3 * * swap 3 * + ;
-
-:: set-bitmap-pixel ( bitmap point color -- )
- point bitmap-index :> index
- color first index bitmap set-nth
- color second index 1 + bitmap set-nth
- color third index 2 + bitmap set-nth ;
-
-: get-bitmap-pixel ( point array -- color )
- ! Point is a {x y}. color is a {r g b}
- [ bitmap-index ] dip
- [ nth ]
- [ [ 1 + ] dip nth ]
- [ [ 2 + ] dip nth ] 2tri 3array ;
-
-CONSTANT: SOUND-SHOT 0
-CONSTANT: SOUND-UFO 1
-CONSTANT: SOUND-BASE-HIT 2
-CONSTANT: SOUND-INVADER-HIT 3
-CONSTANT: SOUND-WALK1 4
-CONSTANT: SOUND-WALK2 5
-CONSTANT: SOUND-WALK3 6
-CONSTANT: SOUND-WALK4 7
-CONSTANT: SOUND-UFO-HIT 8
-
-: init-sound ( index cpu filename -- )
- absolute-path swapd [ sounds>> nth AL_BUFFER ] dip
- create-buffer-from-wav set-source-param ;
-
-: init-sounds ( cpu -- )
- init-openal {
- [ 9 gen-sources swap sounds<< ]
- [ SOUND-SHOT "vocab:space-invaders/resources/Shot.wav" init-sound ]
- [ SOUND-UFO "vocab:space-invaders/resources/Ufo.wav" init-sound ]
- [ sounds>> SOUND-UFO swap nth AL_LOOPING AL_TRUE set-source-param ]
- [ SOUND-BASE-HIT "vocab:space-invaders/resources/BaseHit.wav" init-sound ]
- [ SOUND-INVADER-HIT "vocab:space-invaders/resources/InvHit.Wav" init-sound ]
- [ SOUND-WALK1 "vocab:space-invaders/resources/Walk1.wav" init-sound ]
- [ SOUND-WALK2 "vocab:space-invaders/resources/Walk2.wav" init-sound ]
- [ SOUND-WALK3 "vocab:space-invaders/resources/Walk3.wav" init-sound ]
- [ SOUND-WALK4 "vocab:space-invaders/resources/Walk4.wav" init-sound ]
- [ SOUND-UFO-HIT "vocab:space-invaders/resources/UfoHit.wav" init-sound ]
- [ f swap looping?<< ]
- } cleave ;
-
-: cpu-init ( cpu -- cpu )
- make-opengl-bitmap >>bitmap
- [ init-sounds ] keep
- [ reset ] keep ;
-
-: <space-invaders> ( -- cpu )
- space-invaders new cpu-init ;
-
-: play-invaders-sound ( cpu sound -- )
- swap sounds>> nth source-play ;
-
-: stop-invaders-sound ( cpu sound -- )
- swap sounds>> nth source-stop ;
-
-: read-port1 ( cpu -- byte )
- ! Port 1 maps the keys for space invaders
- ! Bit 0 = coin slot
- ! Bit 1 = two players button
- ! Bit 2 = one player button
- ! Bit 4 = player one fire
- ! Bit 5 = player one left
- ! Bit 6 = player one right
- [ dup 0xFE bitand ] change-port1 drop ;
-
-: read-port2 ( cpu -- byte )
- ! Port 2 maps player 2 controls and dip switches
- ! Bit 0,1 = number of ships
- ! Bit 2 = mode (1=easy, 0=hard)
- ! Bit 4 = player two fire
- ! Bit 5 = player two left
- ! Bit 6 = player two right
- ! Bit 7 = show or hide coin info
- [ port2i>> 0x8F bitand ]
- [ port1>> 0x70 bitand bitor ] bi ;
-
-: read-port3 ( cpu -- byte )
- ! Used to compute a special formula
- [ port4hi>> 8 shift ] keep
- [ port4lo>> bitor ] keep
- port2o>> shift -8 shift 0xFF bitand ;
-
-M: space-invaders read-port
- ! Read a byte from the hardware port. 'port' should
- ! be an 8-bit value.
- swap {
- { 1 [ read-port1 ] }
- { 2 [ read-port2 ] }
- { 3 [ read-port3 ] }
- [ 2drop 0 ]
- } case ;
-
-: write-port2 ( value cpu -- )
- ! Setting this value affects the value read from port 3
- port2o<< ;
-
-:: bit-newly-set? ( old-value new-value bit -- bool )
- old-value bit bit? not new-value bit bit? and ;
-
-: port3-newly-set? ( new-value cpu bit -- bool )
- [ port3o>> swap ] dip bit-newly-set? ;
-
-: port5-newly-set? ( new-value cpu bit -- bool )
- [ port5o>> swap ] dip bit-newly-set? ;
-
-: write-port3 ( value cpu -- )
- ! Connected to the sound hardware
- ! Bit 0 = spaceship sound (looped)
- ! Bit 1 = Shot
- ! Bit 2 = Your ship hit
- ! Bit 3 = Invader hit
- ! Bit 4 = Extended play sound
- over 0 bit? [
- dup looping?>> [
- dup SOUND-UFO play-invaders-sound
- t >>looping?
- ] unless
- ] [
- dup looping?>> [
- dup SOUND-UFO stop-invaders-sound
- f >>looping?
- ] when
- ] if
- 2dup 0 port3-newly-set? [ dup SOUND-UFO play-invaders-sound ] when
- 2dup 1 port3-newly-set? [ dup SOUND-SHOT play-invaders-sound ] when
- 2dup 2 port3-newly-set? [ dup SOUND-BASE-HIT play-invaders-sound ] when
- 2dup 3 port3-newly-set? [ dup SOUND-INVADER-HIT play-invaders-sound ] when
- port3o<< ;
-
-: write-port4 ( value cpu -- )
- ! Affects the value returned by reading port 3
- [ port4hi>> ] [ port4lo<< ] [ port4hi<< ] tri ;
-
-: write-port5 ( value cpu -- )
- ! Plays sounds
- ! Bit 0 = invaders sound 1
- ! Bit 1 = invaders sound 2
- ! Bit 2 = invaders sound 3
- ! Bit 3 = invaders sound 4
- ! Bit 4 = spaceship hit
- ! Bit 5 = amplifier enabled/disabled
- 2dup 0 port5-newly-set? [ dup SOUND-WALK1 play-invaders-sound ] when
- 2dup 1 port5-newly-set? [ dup SOUND-WALK2 play-invaders-sound ] when
- 2dup 2 port5-newly-set? [ dup SOUND-WALK3 play-invaders-sound ] when
- 2dup 3 port5-newly-set? [ dup SOUND-WALK4 play-invaders-sound ] when
- 2dup 4 port5-newly-set? [ dup SOUND-UFO-HIT play-invaders-sound ] when
- port5o<< ;
-
-M: space-invaders write-port
- ! Write a byte to the hardware port, where 'port' is
- ! an 8-bit value.
- swap {
- { 2 [ write-port2 ] }
- { 3 [ write-port3 ] }
- { 4 [ write-port4 ] }
- { 5 [ write-port5 ] }
- [ 3drop ]
- } case ;
-
-M: space-invaders reset
- dup call-next-method
- 0 >>port1
- 0 >>port2i
- 0 >>port2o
- 0 >>port3o
- 0 >>port4lo
- 0 >>port4hi
- 0 >>port5o
- drop ;
-
-: gui-step ( cpu -- )
- [ read-instruction ] keep ! n cpu
- over get-cycles over inc-cycles
- [ swap instructions nth call( cpu -- ) ] keep
- [ pc>> 0xFFFF bitand ] keep
- pc<< ;
-
-: gui-frame/2 ( cpu -- )
- [ gui-step ] keep
- [ cycles>> ] keep
- over 16667 < [ ! cycles cpu
- nip gui-frame/2
- ] [
- [ [ 16667 - ] dip cycles<< ] keep
- dup last-interrupt>> 0x10 = [
- 0x08 >>last-interrupt 0x08 swap interrupt
- ] [
- 0x10 >>last-interrupt 0x10 swap interrupt
- ] if
- ] if ;
-
-: gui-frame ( cpu -- )
- dup gui-frame/2 gui-frame/2 ;
-
-: coin-down ( cpu -- )
- [ 1 bitor ] change-port1 drop ;
-
-: coin-up ( cpu -- )
- [ 255 1 - bitand ] change-port1 drop ;
-
-: player1-down ( cpu -- )
- [ 4 bitor ] change-port1 drop ;
-
-: player1-up ( cpu -- )
- [ 255 4 - bitand ] change-port1 drop ;
-
-: player2-down ( cpu -- )
- [ 2 bitor ] change-port1 drop ;
-
-: player2-up ( cpu -- )
- [ 255 2 - bitand ] change-port1 drop ;
-
-: fire-down ( cpu -- )
- [ 0x10 bitor ] change-port1 drop ;
-
-: fire-up ( cpu -- )
- [ 255 0x10 - bitand ] change-port1 drop ;
-
-: left-down ( cpu -- )
- [ 0x20 bitor ] change-port1 drop ;
-
-: left-up ( cpu -- )
- [ 255 0x20 - bitand ] change-port1 drop ;
-
-: right-down ( cpu -- )
- [ 0x40 bitor ] change-port1 drop ;
-
-: right-up ( cpu -- )
- [ 255 0x40 - bitand ] change-port1 drop ;
-
-TUPLE: invaders-gadget < gadget cpu quit? windowed? ;
-
-invaders-gadget H{
- { T{ key-down f f "ESC" } [ t >>quit? dup windowed?>> [ close-window ] [ drop ] if ] }
- { T{ key-down f f "BACKSPACE" } [ cpu>> coin-down ] }
- { T{ key-up f f "BACKSPACE" } [ cpu>> coin-up ] }
- { T{ key-down f f "1" } [ cpu>> player1-down ] }
- { T{ key-up f f "1" } [ cpu>> player1-up ] }
- { T{ key-down f f "2" } [ cpu>> player2-down ] }
- { T{ key-up f f "2" } [ cpu>> player2-up ] }
- { T{ key-down f f "UP" } [ cpu>> fire-down ] }
- { T{ key-up f f "UP" } [ cpu>> fire-up ] }
- { T{ key-down f f "LEFT" } [ cpu>> left-down ] }
- { T{ key-up f f "LEFT" } [ cpu>> left-up ] }
- { T{ key-down f f "RIGHT" } [ cpu>> right-down ] }
- { T{ key-up f f "RIGHT" } [ cpu>> right-up ] }
-} set-gestures
-
-: <invaders-gadget> ( cpu -- gadget )
- invaders-gadget new
- swap >>cpu
- f >>quit? ;
-
-M: invaders-gadget pref-dim* drop { 224 256 } ;
-
-M: invaders-gadget draw-gadget*
- 0 0 glRasterPos2i
- 1.0 -1.0 glPixelZoom
- [ 224 256 GL_RGB GL_UNSIGNED_BYTE ] dip
- cpu>> bitmap>> glDrawPixels ;
-
-CONSTANT: black { 0 0 0 }
-CONSTANT: white { 255 255 255 }
-CONSTANT: green { 0 255 0 }
-CONSTANT: red { 255 0 0 }
-
-: addr>xy ( addr -- point )
- ! Convert video RAM address to base X Y value. point is a {x y}.
- 0x2400 - ! n
- dup 0x1f bitand 8 * 255 swap - ! n y
- swap -5 shift swap 2array ;
-
-: plot-bitmap-pixel ( bitmap point color -- )
- ! point is a {x y}. color is a {r g b}.
- set-bitmap-pixel ;
-
-: get-point-color ( point -- color )
- ! Return the color to use for the given x/y position.
- first2
- {
- { [ dup 184 238 between? pick 0 223 between? and ] [ 2drop green ] }
- { [ dup 240 247 between? pick 16 133 between? and ] [ 2drop green ] }
- { [ dup 247 215 - 247 184 - between? pick 0 223 between? and ] [ 2drop red ] }
- [ 2drop white ]
- } cond ;
-
-: plot-bitmap-bits ( bitmap point byte bit -- )
- ! point is a {x y}.
- [ first2 ] 2dip
- dup swapd -1 * shift 1 bitand 0 =
- [ - 2array ] dip
- [ black ] [ dup get-point-color ] if
- plot-bitmap-pixel ;
-
-: do-bitmap-update ( bitmap value addr -- )
- addr>xy swap 8 <iota> [ plot-bitmap-bits ] with with with each ;
-
-M: space-invaders update-video
- over 0x2400 >= [
- bitmap>> -rot do-bitmap-update
- ] [
- 3drop
- ] if ;
-
-: sync-frame ( micros -- micros )
- ! Sleep until the time for the next frame arrives.
- 16,667 + system:nano-count - dup 0 >
- [ 1,000 * threads:sleep ] [ drop threads:yield ] if
- system:nano-count ;
-
-: invaders-process ( micros gadget -- )
- ! Run a space invaders gadget inside a
- ! concurrent process. Messages can be sent to
- ! signal key presses, etc.
- dup quit?>> [
- exit-openal 2drop
- ] [
- [ sync-frame ] dip {
- [ cpu>> gui-frame ]
- [ relayout-1 ]
- [ invaders-process ]
- } cleave
- ] if ;
-
-M: invaders-gadget graft*
- dup cpu>> init-sounds
- f >>quit?
- [ system:nano-count swap invaders-process ] curry
- "Space invaders" threads:spawn drop ;
-
-M: invaders-gadget ungraft*
- t swap quit?<< ;
-
-: run-rom ( title cpu rom-info -- )
- over load-rom* <invaders-gadget> t >>windowed? swap open-window ;
-
-CONSTANT: rom-info {
- { 0x0000 "invaders/invaders.h" }
- { 0x0800 "invaders/invaders.g" }
- { 0x1000 "invaders/invaders.f" }
- { 0x1800 "invaders/invaders.e" }
-}
-
-: run-invaders ( -- )
- [
- "Space Invaders" <space-invaders> rom-info run-rom
- ] with-ui ;
-
-MAIN: run-invaders
+++ /dev/null
-Intel 8080-based Space Invaders arcade machine emulator
+++ /dev/null
-demos
-games
-applications
projects / factor.git / commitdiff