New keys for qbert

README.md

@@ -282,7 +282,7 @@ Lots of games work:
 | Pinball                | Seems to work fine.                                                      |
 | Planet Patrol          | Seems to play fine apart from a bad pixel at top of screen               |
 | Pole Position          | Seems to play fine modulo some misrendered pixels.                       |
-| Q*Bert                 | Seems to play fine                                                       |
+| Q*Bert                 | Seems to play fine. Use qbert-options and keys I,O,K,L.                  |
 | Quest for Quintana Roo | Seems to play fine.                                                      |
 | Raiders of Lost Ark    | Starts fine. Might need controllers I don't emulate yet.                 |
 | River Patrol           | Use -b 3f. Seems to play fine.                                           |

Stellarator.cabal

@@ -32,6 +32,8 @@ library
                      , vector
                      , OpenGL
                      , array
+                     , bytestring
+                     , proteaaudio
                      , mtl
                      , lens
                      , binary
@@ -59,6 +61,7 @@ executable stellarator-exe
                      , mtl
                      , lens
                      , binary
+                     , proteaaudio
                      , cmdargs
                      , monad-loops
                      , parsec

app/Main.hs

@@ -32,6 +32,7 @@ import System.Console.CmdArgs hiding ((+=))
 import Graphics.UI.GLFW
 import Data.IORef
 import Data.Dequeue
+import Sound.ProteaAudio
 #if TRACE
 import Data.Array.Storable
 #endif
@@ -138,11 +139,15 @@ main = do
     let controllerType = read controllerTypeString
     let alpha = motionBlurAlpha options'
 
-    rc <- init
-    when (not rc) $ die "Couldn't init"
+    rc <- init -- init video
+    when (not rc) $ die "Couldn't init graphics"
     queueRef <- newIORef empty
     window <- makeMainWindow screenScaleX' screenScaleY' queueRef
 
+    -- init audio
+    result <- initAudio 64 44100 1024
+    unless result $ die "Couldn't init sound"
+
     (prog, attrib, tex', lastTex', textureData', lastTextureData') <- initResources alpha
 
     romArray <- newArray (0, 0x7fff) 0 :: IO (IOUArray Int Word8)

qbert-options

@@ -0,0 +1,56 @@
+Options {
+    screenScaleX = 5,
+    screenScaleY = 3,
+    topOverscan = 10,
+    bottomOverscan = 10,
+    motionBlurAlpha = 1.0,
+
+    controllerTypes = "Joysticks",
+
+    joystick1Left = ["I"],
+    joystick1Right = ["L"],
+    joystick1Up = ["O"],
+    joystick1Down = ["K"],
+    joystick2Left = ["LeftBracket"],
+    joystick2Right = ["RightBracket"],
+    joystick2Up = ["Equals"],
+    joystick2Down = ["Apostrophe"],
+    joystick1Trigger = ["Space"],
+    joystick2Trigger = ["Return"],
+    dumpState = ["1"],
+    gameQuit = ["Q"],
+    gameSelect = ["C"],
+    gameReset = ["V"],
+    tvType = ["X"],
+    enterDebugger = ["Escape"],
+    debugMode = ["Backslash"],
+    writeRecord = ["W"],
+    delayLeft = [],
+    delayRight = [],
+    delayUp = [],
+    delayDown = [],
+    keyboardController00 = ["7"],
+    keyboardController01 = ["6"],
+    keyboardController02 = ["5"],
+    keyboardController03 = ["0"],
+    keyboardController04 = ["9"],
+    keyboardController05 = ["8"],
+    keyboardController10 = ["U"],
+    keyboardController11 = ["Y"],
+    keyboardController12 = ["T"],
+    keyboardController13 = ["P"],
+    keyboardController14 = ["1"],
+    keyboardController15 = ["1"],
+    keyboardController20 = ["J"],
+    keyboardController21 = ["H"],
+    keyboardController22 = ["G"],
+    keyboardController23 = ["Semicolon"],
+    keyboardController24 = ["1"],
+    keyboardController25 = ["1"],
+    keyboardController30 = ["M"],
+    keyboardController31 = ["N"],
+    keyboardController32 = ["B"],
+    keyboardController33 = ["Slash"],
+    keyboardController34 = ["Period"],
+    keyboardController35 = ["Comma"]
+}

src/Emulation.hs

@@ -9,13 +9,17 @@ module Emulation where
 
 import Asm hiding (a, s)
 import Atari2600
+import System.IO.Unsafe
 import Control.Lens hiding (set, op, index)
 import Control.Monad.Reader
+import Data.Maybe
 import Data.Array.IO hiding (index)
 import Data.Bits hiding (bit)
+import Data.ByteString hiding (putStrLn, putStr)
 import Data.IORef
 import Data.Int
 import CPU
+import Sound.ProteaAudio
 import Data.Word
 import DebugState
 import Control.Concurrent
@@ -1025,6 +1029,17 @@ dumpState = do
 
 -}
 
+samplesRef = unsafePerformIO (newIORef Nothing)
+audioSamples = pack [truncate (127*sin(10*2*pi*t/1024)) | t <- [0..4095]]
+
+doAudio v = do
+    x <- readIORef samplesRef
+--     when (isJust x) $ void $ soundStop (fromJust x)
+    when (isNothing x) $ do
+        samples <- sampleFromMemoryPcm audioSamples 1 44100 8 (fromIntegral (0xf .&. 0xf::Word8) / 15.0)
+        writeIORef samplesRef (Just samples)
+        soundLoop samples 1 1 0 1 -- left volume, right volume, time difference between left and right, pitch factor for playback
+
 -- {- INLINABLE writeStella -}
 writeStella :: Word16 -> Word8 -> MonadAtari ()
 writeStella addr v = do
@@ -1057,6 +1072,14 @@ writeStella addr v = do
        0x12 -> (pcStep @-> pcResm0) >> hpos @-> mpos0 -- RESM0
        0x13 -> (pcStep @-> pcResm1) >> hpos @-> mpos1 -- RESM1
        0x14 -> (pcStep @-> pcResbl) >> load hpos >>= (return . max (picx+2)) >>= (bpos @=)  -- RESBL
+       0x15 -> return () -- liftIO $ putStrLn $ "AUDC0 = " ++ showHex v ""
+       0x16 -> return () -- liftIO $ putStrLn $ "AUDC1 = " ++ showHex v ""
+       0x17 -> return () -- liftIO $ putStrLn $ "AUDF0 = " ++ showHex v ""
+       0x18 -> return () -- liftIO $ putStrLn $ "AUDF1 = " ++ showHex v ""
+       0x19 -> return () -- liftIO $ do
+                        -- putStrLn $ "AUDV0 = " ++ showHex v ""
+                        -- doAudio v
+       0x1a -> return () -- liftIO $ putStrLn $ "AUDV1 = " ++ showHex v ""
        -- graphicsDelay of 1 chosen to stop spurious pixel in
        -- "CCE" in Freeway.
        0x1b -> do -- GRP0

stack.yaml

@@ -6,4 +6,5 @@ packages:
 - .
 extra-deps:
 - dequeue-0.1.12@sha256:547c2a71819dca0ae1bf7c15fb290b39f80d5d9a6f9985a06a1cb8645b578df2
+- proteaaudio-0.7.1.0@sha256:926a4437d239d453fc629c33ab5512211a6e6fe300c2f86efc6238ac1d587aa1
 resolver: lts-13.23